Application Project Umsatzprognose Bäckerei
Application Project Umsatzprognose Bäckerei
- 1. Allgemeine Projektinformationen
- 2 Datenexploration
- 2.1 Einlesen der Daten
- 2.2 Überprüfung der Datenstrukturen
- 2.3 Überprüfung des Anfangs- und Endzeitpunkt der Datumsattribute in den Datensätzen
- 2.4 Überprüfung der Datensätze auf fehlende Werte
- 2.5 Überprüfung des Datensatzes auf Vollständigkeit
- 2.6 Überprüfung der Datensätze auf Ausreißer
- 2.7 Deskriptive Statistik
- 3 Datenaufbereitung, Erstellung von Rohdatensatz und Analysedatensätzen
- 3.1 Umgang mit Ausreißern
- 3.2 Umgang mit Warengruppe 6
- 3.3 Rohdaten mit vollständiger Zeitreihe
- 3.4 Vereinigung der Datensätze
- 3.5 Korrektur der Anzahl Nachkommastellen für einzelne Variablen
- 3.6 Umgang mit fehlenden Werten
- 3.7 Ergänzung um die Variablen Wochentag, Monat und Jahr
- 3.8 Ergänzung um Sommerferienvariablen
- 3.9 Ergänzung um Feiertagsvariablen
- 3.10 Ergänzung um Variable Jahreszeit
- 3.11 vollständige Datenreihe, Imputationen, Trainingsdaten, Testdaten
- 4. Deskriptive Analysen
- 5 Anwendung naiver Modelle
- 6 Anwendung statistischer Modelle - Lineare Regression
- 7 Anwendung von ML Verfahren: Support Vector Machines (SVM)
- 8 Anwendung von DL Verfahren: Multilayer Perceptron (MLP)
- 9. Modellvergleich über alle verwendeten Verfahren
1. Allgemeine Projektinformationen
1.1 Ausgangslage
Die Bestellung von Bäckereien ist häufig noch ein manueller und zeitaufwändiger Prozess, der auf adjustierten Vorwochenwerten basiert. Eine systematische Planung unter Einbeziehung von Mustern findet nur eingeschränkt statt.
1.2 Zielsetzung
Es wird ein Prognosemodell entworfen, das Bäckereien ein bessere Planungsgrundlage auf Warengruppenebene bietet.
Lösungsansatz
Mit Hilfe von verschiedenen Daten und Einflussfaktoren soll diese Umsätze je Warengruppe prognostiziert werden.
- Umsatzdaten, Wetterdaten, Veranstaltungsdaten
- Weitere Einflussfaktoren (Wochentage, Feiertage, Ferien,…)
1.3 Datenbasis
Untersucht werden Daten für die Jahre 2013 bis 2019. Es liegen für diesen Zeitraum als Rohdaten drei Datensätze vor:
- Umsätze je Warengruppe und Tag
- Es werden fünf Warengruppen in die Analysen einbezogen: Brot (WG 1), Brötchen (WG 2), Croissant (WG 3), Konditorei (WG 4) und Kuchen (WG 5)
- Daten zur Kieler Woche
- Wetterdaten
- Informationen zu den Wetterdaten können der privaten Webseite von Mario Lehwald entnommen werden. Herr Lehwald hat seine Daten wiederum vom Geomar - Helmholtz-Zentrum für Ozeanforschung Kiel sowie vom Windfinder bezogen (vgl. Impressum)
2 Datenexploration
2.1 Einlesen der Daten
Im ersten Schritt müssen die Daten zunächst eingelesen werden um sie bearbeiten zu können:
2.2 Überprüfung der Datenstrukturen
- Datensatz Beispieldaten
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 11164 obs. of 3 variables:
## $ Datum : Date, format: "2013-07-01" "2013-07-02" ...
## $ Warengruppe: num 1 1 1 1 1 1 1 1 1 1 ...
## $ Umsatz : num 149 160 112 169 171 ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. Warengruppe = col_double(),
## .. Umsatz = col_double()
## .. )
## Observations: 11,164
## Variables: 3
## $ Datum <date> 2013-07-01, 2013-07-02, 2013-07-03, 2013-07-04, 2...
## $ Warengruppe <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ Umsatz <dbl> 148.82835, 159.79376, 111.88559, 168.86494, 171.28...
## [1] "double"
## [1] "2019-07-30"
## [1] 1 6
## [1] 7.051201 1879.461831
## # A tibble: 6 x 3
## Datum Warengruppe Umsatz
## <date> <dbl> <dbl>
## 1 2013-07-01 1 149.
## 2 2013-07-02 1 160.
## 3 2013-07-03 1 112.
## 4 2013-07-04 1 169.
## 5 2013-07-05 1 171.
## 6 2013-07-06 1 175.
## # A tibble: 6 x 3
## Datum Warengruppe Umsatz
## <date> <dbl> <dbl>
## 1 2018-12-21 6 51.8
## 2 2018-12-22 6 66.7
## 3 2018-12-23 6 50.0
## 4 2018-12-24 6 46.1
## 5 2018-12-27 6 51.6
## 6 2018-12-28 6 35.2
Der Datensatz Beispieldaten ist ein Dataframe, enthält 11164 Zeilen und 3 Variablen:
- Datum (
date) - Warengruppe (
int) mit den Warengruppen 1 - 6 - Umsatz (
dbl) mit Werten zwischen 7.05 und 1879.46.
Umsätze werden jeweils 5 mit Nachkommastellen angezeigt. Hier wird später eine Änderung vorgenommen und die Variable auf zwei Nachkommastellen gerundet.
- Datensatz KiWo
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 72 obs. of 2 variables:
## $ Datum : Date, format: "2012-06-16" "2012-06-17" ...
## $ KielerWoche: num 1 1 1 1 1 1 1 1 1 1 ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. KielerWoche = col_double()
## .. )
## Observations: 72
## Variables: 2
## $ Datum <date> 2012-06-16, 2012-06-17, 2012-06-18, 2012-06-19, 2...
## $ KielerWoche <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
any(KiWo$KielerWoche != 1) # Prüfung: Ist die Ausprägung in irgendeiner Zelle der Spalte ungleich 1?## [1] FALSE
## [1] TRUE
Der Datensatz KiWo enthält 71 Zeilen und die beiden Variablen Datum (date) und KielerWoche (int), wobei die einzige Ausprägung der Variablen KielerWoche die Ziffer 1 ist. Anhand der Daten der einzelnen Daten erkennt man, dass der Datensatz nur solche Daten enthält, an denen tatsächlich die Kieler Woche in dem jeweiligen Jahr stattgefunden hat.
- Datensatz Wetter
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 2601 obs. of 5 variables:
## $ Datum : Date, format: "2012-01-01" "2012-01-02" ...
## $ Bewoelkung : num 8 7 8 4 6 3 7 7 8 6 ...
## $ Temperatur : num 9.82 7.44 5.54 5.69 5.3 ...
## $ Windgeschwindigkeit: num 14 12 18 19 23 10 14 10 12 10 ...
## $ Wettercode : num 58 NA 63 80 80 NA 61 80 61 NA ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. Bewoelkung = col_double(),
## .. Temperatur = col_double(),
## .. Windgeschwindigkeit = col_double(),
## .. Wettercode = col_double()
## .. )
## Observations: 2,601
## Variables: 5
## $ Datum <date> 2012-01-01, 2012-01-02, 2012-01-03, 2012-...
## $ Bewoelkung <dbl> 8, 7, 8, 4, 6, 3, 7, 7, 8, 6, 6, 7, 2, 3, ...
## $ Temperatur <dbl> 9.825000, 7.437500, 5.537500, 5.687500, 5....
## $ Windgeschwindigkeit <dbl> 14, 12, 18, 19, 23, 10, 14, 10, 12, 10, 16...
## $ Wettercode <dbl> 58, NA, 63, 80, 80, NA, 61, 80, 61, NA, 51...
## [1] 0 8
## [1] -10.25000 32.67143
## [1] 3 35
## [1] 0 95
Der Datensatz Wetter enthält 2601 Zeilen und fünf Variablen:
- Datum (
date) - Bewoelkung (
int) mit Werte von 0 bis 8 - Temperatur (
dbl) mit Werten zwischen -10.25 und 32.67 Grad Celsius - Windgeschwindigkeit (
int) mit Werten zwischen 3 und 35 Knoten - Wettercode (
int) mit Werten zwischen 0 und 95, wobei die einzelnen Wettercodes einer bestimmten Wettererscheinung oder einem bestimmten Wetterzustand entsprechen.
Weitere Informationen zu den einzelnen Variablen des Datensatzes Wetter und ihrer Interpretation können der privaten Webseite Seewetter Kiel entnommen werden.
Alle Datensätze enthalten die Variable Datum. Folglich können die einzelnen Datensätze über diese Variable vereinigt werden.
2.3 Überprüfung des Anfangs- und Endzeitpunkt der Datumsattribute in den Datensätzen
## [1] "2013-07-01"
## [1] "2019-07-30"
## [1] "2012-06-16" "2019-06-30"
## [1] "2012-01-01" "2019-08-01"
- Die Daten des Datensatzes Beispieldaten reichen vom 01.07.2013 bis zum 30.07.2019.
- Die Daten des Datensatzes KiWo reichen vom 16.06.2012 bis zum 30.06.2019.
- Die Daten des Datensatzes Wetter reichen vom 01.01.2012 bis zum 01.08.2019.
2.4 Überprüfung der Datensätze auf fehlende Werte
Überprüfung auf “klassische” fehlende Werte (NA)
Zunächst einmal wird geprüft, welche klassischen fehlenden Werte (NA) in den einzelnen Datensätzen vorhanden sind:
## [1] 0
## [1] 0
## [1] 679
## [1] 0
## [1] 10
## [1] 0
## [1] 0
## [1] 669
- Der Datensatz Beispieldaten enthält keine fehlenden Werte.
- Der Datensatz KiWo enthält keine fehlenden Werte.
- Der Datensatz Wetter enthält 679 fehlende Werte, davon 10 in der Spalte “Bewoelkung”, 669 in der Spalte “Wettercode”.
2.5 Überprüfung des Datensatzes auf Vollständigkeit
In In einem weiteren Schritt wird geprüft, ob die Anzahl der Zeilen pro Jahr stimmt.
In den Jahren 2014, 2015, 2017 und 2018, die vollständig vorliegen, müssten es je Warengruppe 365 Zeilen sein, im Schaltjahr 2016 366. Für das Jahr 2013, für das Daten erst ab dem 01.07.2013 zur Verfügung stehen, entsprechend 183 und für das unvollständige Jahr 2019 müssten 210 Datensätze vorliegen. Insgesamt müssten für jede Warengruppe demnach 2219 Zeilen vorhanden sein.
Beispieldaten <- Beispieldaten %>% mutate(Jahr = year(Datum))
# 2174 -> 45 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2120
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
Es fehlen bei allen Warengruppen Datensätze. Bei den Warengruppen 1,2, 3 und 5 fallen ca. 70% der fehlenden Daten auf Feiertage (insb. Karfreitag, Tag der Arbeit und 1. und 2. Weihnachtsfeiertag). Bei Warengruppe 4 sind es ca. 30%. Weitere ~30% der fehlenden Daten der Warengruppe 4 liegen in den Sommermonaten Juni, Juli, August. Eine Möglichkeit wäre, dass die Kühlung ausgefallen ist / einen Defekt hatte und demzufolge keine Konditoreiwaren angeboten wurden. Eine andere Möglichkeit wäre, dass bei sehr trockenem, warmen Wetter der Verkauf von Konditoreiwaren in der Regel ein Minusgeschäft ist und daher das Sortiment temporär/tageweise verkleinert wird. Auffällig ist, dass die Anzahl der fehlenden Werte pro Jahr abnehmend ist und sich insbesondere in den Jahren 2012 und 2018 mehrheitlich auf Feiertage beschränkt.
Untersucht man die einzelnen Jahre genauer, ergibt sich folgendes Bild:
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 165 -> 17 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 165
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 334 -> 31 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 334
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 350 -> 15 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 350
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 352 -> 14 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 352
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
Je Warengruppe und Jahr fehlen unterschiedliche viele Datensätze.
2.6 Überprüfung der Datensätze auf Ausreißer
Ein Ausreißer ist ein Wert, der außerhalb der üblichen Struktur einer Verteilung liegt. Zunächst wird in einem ersten Schritt mittels einer Visualisierung in Form von boxplots überprüft, ob die einzelnen Datensätze überhaupt Ausreißer enthalten.
Die Überprüfung wird begonnen mit dem Datensatz Beispieldaten:
##
## Call:
## density.default(x = Beispieldaten$Umsatz)
##
## Data: Beispieldaten$Umsatz (11164 obs.); Bandwidth 'bw' = 19.24
##
## x y
## Min. : -50.68 Min. :0.000e+00
## 1st Qu.: 446.29 1st Qu.:1.040e-07
## Median : 943.26 Median :2.312e-06
## Mean : 943.26 Mean :5.026e-04
## 3rd Qu.:1440.22 3rd Qu.:3.011e-04
## Max. :1937.19 Max. :4.894e-03
Das Attribut Umsatz enthält zahlreiche Ausreißer. Mit bloßem Auge ist nicht zu erkennen, wie viele Ausreißer es genau sind. Die Ausreißer werden also in einem 2. Schritt genauer betrachtet, um die genaue Anzahl der Ausreißer zu ermitteln. Statistiker haben viele Verfahren entwickelt, um auseinanderzuhalten, was man als Ausreißer bezeichnen sollte, und was nicht.
Eine mögliche Definition und oft benutzte Regel, die von John W. Tukey stammt, besteht darin, dass ein Wert ein Ausreißer ist, falls er deutlich oberhalt des oberen Quartils (Q_3) oder unterhalb des unteren Quartils (Q_1) liegt. Dabei bezieht er den Abstand des oberen zum unteren Quartil mit ein, genannt “interquartile range” (IQR) und definiert einen Ausreißer als einen Punkt, der mehr als \[1,5 * IQR\] vom oberen Quartils bzw. unteren Quartil abweicht. Anders gesagt liegen untere Ausreißer unterhalb
\[Q_1 - 1,5 * IQR\] und obere Ausreißer oberhalb \[Q_3 + 1.5 * IQR\]
Vereinfachend untersuchen wir nun die Umsatzvariable insgesamt auf Ausreißer, wobei wir zunächst nicht nach Warengruppen trennen:
g_oben <- quantile(Beispieldaten$Umsatz, probs=0.75) + (1.5*IQR(Beispieldaten$Umsatz)) #Obere Grenze fuer Ausreißer
g_oben## 75%
## 559.7999
## # A tibble: 1 x 1
## n
## <int>
## 1 348
Die obere Grenze für Ausreißer liegt demzufolge bei 559,80€ (gerundet). Es gibt insgesamt 348 Ausreißer in der Variable Umsatz. In einem 3. Schritt betrachten wir, an welchen Daten diese Ausreißer auftreten und ob Muster erkennbar sind (z. B. überproportional hohe Umsätze an Ostern oder anderen Feiertagen, in den Ferien, während der Kieler Woche o. Ä.):
## # A tibble: 348 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2013-07-06 632. 2
## 2 2013-07-07 695. 2
## 3 2013-07-09 586. 2
## 4 2013-07-10 567. 2
## 5 2013-07-11 569. 2
## 6 2013-07-12 600. 2
## 7 2013-07-13 747. 2
## 8 2013-07-14 777. 2
## 9 2013-07-15 597. 2
## 10 2013-07-17 628. 2
## # ... with 338 more rows
Beispieldaten %>%
select(Datum, Umsatz, Warengruppe) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz))## # A tibble: 348 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2014-12-31 1879. 5
## 2 2015-12-31 1870. 5
## 3 2016-12-31 1705. 5
## 4 2018-12-31 1668. 5
## 5 2013-12-31 1626. 5
## 6 2017-12-31 1432. 5
## 7 2014-05-05 1203. 2
## 8 2013-08-03 931. 2
## 9 2014-08-09 875. 2
## 10 2013-07-28 872. 2
## # ... with 338 more rows
## # A tibble: 4 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2018-12-31 264. 1
## 2 2018-12-31 618. 2
## 3 2018-12-31 255. 3
## 4 2018-12-31 1668. 5
Erste Erkenntnisse (nach Jahren sortiert):
- Eine erste Ausreißerperiode ist - mit zwei Ausnahmetagen (Mo, 08.07.; Di, 16.07.) - in dem Zeitraum vom 06.07.2013 (Samstag) bis zum 04.08.2013 (Sonntag) zu beaobachten. Vergleicht man diese Periode mit den Ferienzeiten der verschiedenen Bundesländer im Jahr 2013, so fällt auf, dass insbesondere die für den Tourismus in Schleswig-Holstein relevanten Bundesländer Hessen, Niedersaschsen, Rheinland-Pfalz, sowie teilweise Nordrhein-Westfalen (ab. 22.07.) in diesem Zeitraum Ferien hatten. Weiterhin lagen auch die Ferien der Berliner und der Schleswig-Holsteiner selbst sowie die der Bayern teilweise in diesem Zeitraum. Die Vermutung liegt insofern nahe, dass die Sommerferien einen signifikanten Einfluss auf die Höhe des Umsatzes der betrachtenen Filiale haben.
- Nach dieser wirklich sichtbaren, anhaltenden Periode von überproportional hohen Umsätzen folgt eine Phase - beginnend am Samstag, 10.08.2013 -, in der ausschließlich an den beiden Wochenendtagen Ausreißer-Umsätze zu beobachten sind. Diese Phase endet am 08.09.2013 (Ausnahme in dieser Phase ist So, 01.09.).
- Nach dieser Wochenend-Ausreißerphase wird es erkennbar unregelmäßiger:
- vereinzelt gibt es weiterhin Ausreißer an Wochenendtagen (z. B. am So, 28.09.; So, 17.11.; So, 24.11.; 01.12.; 25.12.)
- auch an einzelnen Feiertagen / besonderen Ereignissen sind die Umsätze überproportional stark (03.10. (Tag der Deutschein Einheit); 31.12. (Silvester)).
- die Herbst- und Winterferien sowie Weihnachten bzw. die Weihnachtsfeiertage scheinen insofern keinen signifikanten Einfluss auf die Umsätze der Bäckerei zu haben.
- Insgesamt gibt es im Jahr 2013 zwei Tage (So, 11.08. und Di, 31.12.), an denen zwei Warengruppen Ausreißer sind (jeweils Warengruppen 2 + 5).
- Das Jahr 2014 beginnt strukturell so wie das Vorjahr geendet hat: unregelmäßig. Vereinzelt gibt es Ausreißer an Wochenendtagen (So, 12.01.; jeweils der Sonntag in der Zeit vom 09.02. - 09.03.; Sa, 29.03.; So, 06.04.).
- Ab Sa, 12.04. bis Ende April am So, 27.04. sind jeweils beide Wochenendtage überproportional stark (Anmerkung: Ferienzeit in vielen relevanten Bundesländern); auch an Ostern (Karfreitag 18.04., Ostersonntag 20.04. sowie Ostermontag 21.04.) sind starke Umsatz-Effekte zu beobachten.
- Ein ungewöhnlich hoher Umsatz ist am Montag, 05.05.2014 zu beobachten; es ist der höchste Umsatz im gesamten Zeitraum; ansonsten gibt es an den Sonntagen 18.05 und 25.05. Ausreißer sowie an Christi Himmelfaht (29.05.).
- Im Zeitraum vom 31.05. bis 29.06. erstrecken sich die Ausreißer wiederum über beide Wochentage; hinzu kommt in diesem Zeitraum ein (eingeschränkter) Effekt der Kieler Woche (Ausreißer am Do, 26.06. und Fr, 27.06.).
- Im Juli sind am Sa, 05.07. sowie von Fr, 11.07. - So, 13.07 die “üblichen” Wochenendeffekte zu beobachten.
- Im Zeitraum vom 17.07. - 31.08 - also in einem Zeitraum von ca. 6 Wochen - jeden Tag Ausreißer zu verzeichnen; betrachtet man die Sommerferienzeiträume der Bundesländer im Jahr 2014, so liegt die Vermutung nahe, dass wie schon im Vorjahr die Ferienzeit diese überporportional hohen Umsätze signifkant beeinflusst hat.
- An den ersten drei Septemberwochenenden sowie an den Oktoberwochenenden sind ebenfalls Ausreißer zu verzeichnen; hinzu kommt im Oktober zudem der Tag der Deutschen Einheit.
- Im November beschränken sich die Ausreißerumsätze auf die Sonntage; dies gilt mit Ausnahme des So, 21.12. auch für den Dezember; hinzu kommen im Dezember weiterhin der Di, 30. und der Mi, 31.12; auch im Jahr 2014 ist wieder kein “Weihnachts-Effekt” sichtbar.
- Insgesamt gibt es im Jahr 2014 einen Tag (Mi, 31.12.), an denen zwei Warengruppen Ausreißer sind (jeweils WG 2 + 5). Am 05.05. gibt es sogar Ausreißer in drei Warengruppen (WG 2, 3, 5).
- Mit mehr als 120 Ausreißern innerhalb eines Jahres ist das Jahr 2014 ein vglw. außergewöhnlich “ausreißerstarkes” Jahr (gewöhnlich liegt die Anzahl pro Jahr zwischen ~ 30 - 50 Ausreißern). Man könnte das Jahr 2014 selbst fast als Ausreißerjahr bezeichnen.
- Im Zeitraum Januar bis März sind insgesamt nur vier Ausreißer zu beobachten; diese liegen jeweils auf einem Sonntag
- Das Osterwochenende im April (So, 05.04 + Mo, 06.04.) ist gewohnt stark; im Unterschied zu 2014 ist jedoch an Karfreitag kein Ausreißer-Umsatz zu verzeichnen. Ansonsten ist der April nicht von Ausreißern betroffen.
- Der Monat Mai + Anfang sind vergleichbar mit dem Vorjahr: überproportional hohe Umsätze am Sonntag nach Himmelfahrt (17.05.) sowie am Pfingstwochende (So, 24. + Mo, 25.05.).
- Der Juni erscheint schwächer als im Vorjahr; es ist lediglich ein leichter Wochenendeffekt sichtbar (Sa, 13.06., Sa, 20.06; sowie am zweiten “KiWo-Wochenende” 27. + 28.06.), der Effekt der Kieler Woche ist schwächer im Vergleich zum Vorjahr.
- Auch im Jahr 2015 scheinen die Sommerferien einen Einfluss zu haben, jedoch einen geringeren als im Vorjahr:
- im Juli sind in den ersten drei Wochen (01.07. - 19.07.) nur Wochenendeffekte zu beobachten
- die Phase, in der jeder Tag ein Ausreißer ist, erstreckt sich 2015 nur über 3 Wochen (20.07. - 09.08.); in der Woche vom 10.08 - 16.08. sind zwar noch vier Ausreißer zu verzeichnen, ansonsten beschränken sich die Ausreißer im Rest des Augustes auf die Wochenenden.
- Der nächste und einzige weitere Ausreißer im Jahr 2015 ist an Silvester zu beobachten.
- Im Jahr 2016 taucht der erste Ausreißer am Sonntag des ersten Februarwochenendes auf (07.02.).
- Das Osterwochenende Ende März (Sa, 04.04 + Mo, 06.04.) ist abermals stark, an jedem Tag sind Ausreißer zu finden.
- Im April gibt es im Jahr 2016 keinen einzigen Ausreißer, wobei in diesem Jahr auch kein Feiertag in den April fällt.
- Wie schon im Vorjahr ist an Christi Himmelfahrt (05.05.) selbst kein Ausreißer zu beobachten, wohl aber an dem darauf folgenden Sonntag (wie 2015). Ein weiterer Ausreißer im Mai liegt auf dem Pfingstmontag (16.05.).
- Die Kieler Woche-Umsätze sind abermals schwach mit Blick auf Ausreißer; lediglich am 2. KiWo-Wochenende sind Ausreißer zu verzeichnen.
- Die Sommerferienzeit von Ende Juli bis Mitte August ist wie gewohnt mit vielen Ausreißern versehen, jedoch weniger als in den beiden Vorjahren. Ende August beschränken sich die Ausreißer auf die beiden Wochenendtage.
- Der Rest des Jahres verläuft ausreißertechnisch typisch. Es gibt zwei vereinzelte Ausreißer an zwei Sonntagen (02.10. und 18.12); Silvester ist erwartbar stark, sowohl in Warengruppe 2 als auch in Warengruppe 5.
- Was AUsreißer anbelangt, ist das Jahr 2017 ein auffällig schwaches Jahr. Es ist mit knapp 30 Ausreißern im ganzen Jahr das schwächste von allen (Vgl. 2014: > 120).
- Die ersten beiden Ausreißer sind erst im April am Osterwochenende (15. + 16.04.) zu beobachten; ein weiterer Ausreißer kommt am letzten Aprilsonntag vor, im Mai gibt es nur einen Ausreißer am Sonntag nach Christi Himmelfahrt.
- Im Juni gibt es einen bemerkenswerten Ausreißer am Mo, 05.06. (Montag generell ungewöhnlich für Ausreißer); weiterhin sind an den beiden KiWo-Wochenenden Ausreißer zu verzeichnen.
- Ein gewisser Sommerferieneffekt ist sichtbar, dieser ist jedoch deutlich schwächer al sin den Vorjahren.
- Bemerkenswert ist ein zweiter Ausreißer an Heiligabend. 2017 ist das einzige Jahr, in dem Weihnachten bzw. genauer Heiligabend einen Ausreißer in der Warengruppe 2 zu verzeichnen hat.
- Zudem ist 2017 das einzige Jahr, in dem an Silvester kein Ausreißer in Warengruppe 2 zu beobachten ist.
Fazit: Insgesamt ein eher untypisches Jahr was Ausreißer anbelangt, sowohl von der Anzahl her als auch teilweise von der Verteilung.
- Im Jahr 2018 gibt es einen ersten Ausreißer am Ostersonntag Anfang April (01.04.); der Mai profitiert von der Lage von Christi Himmelfahrt und Pfingsten.
- Im Juni sind an den beiden Wochenenden vor der KiWo einzelne Ausreißer zu verzeichnen; das erste KiWo-Wochenende ist stark. Insbesondere der Sa, 23.06. ist auffällig, das es der einzige Samstag ist, an dem für zwei Warengruppen (2 + 5) Ausreißer zu verzeichnen sind.
- Der gewohnte Sommerferien-Effekt ist von Mitte Juli bis Mitte August bemerkbar und wieder deutlich stärker als im Vorjahr. Ein letzter Ausreißer im August ist am Sa, 25.08. zu verzeichnen. Danach gibt es im gesamten Jahresverlauf nur noch den gewohnten Silvesterausreißer.
- Im Jahr 2019 gibt es zwei vereinzelte Sonntags-Ausreißer Ende Februar und Ende März.
- Ostern, Christi Himmelfahrt und Pfingsten sind gewohnt stark:
- Ostern: Ausreißer von Sa, 20.04. - Mo, 22.04.
- Christi Himmelfahrt: Sowohl an Christi Himmelfahrt selbst (30.05.) als auch am darauffolgenden Samstag (01.06.) sind Ausreißer beobachtbar.
- Am Pfingstwochenende (Sa, 08. - Mo, 10.06.) sind an allen Tagen Ausreißer zu verzeichnen.
- Wiederum stark im Juni sind die beiden Kieler Woche-Wochenenden (22.-23. sowie 29.-30.06.).
- Der Sommerferieneffekt beginnt Mitte Juli (Sa, 13.07.) und hält bis zum Ende des Monats an.
!!!!!!!!!!! an anderer Stelle einfügen oder ganz löschen !!!!!!!!!!!!!!!!!!!!!!!!
Am Ende der Auswertung wird deutlich, dass für einzelne Daten, z. B. den 05.05.2014, mehrere Umsätze vorhanden sind. Eine Überprüfung auf doppelt belegte Daten ergibt:
Beispieldaten %>%
select(Datum, Umsatz, Warengruppe) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz)) %>%
filter(duplicated(Datum))## # A tibble: 9 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2014-05-05 749. 5
## 2 2018-06-23 662. 5
## 3 2015-12-31 644. 2
## 4 2014-12-31 643. 2
## 5 2018-12-31 618. 2
## 6 2013-12-31 586. 2
## 7 2013-08-11 583. 5
## 8 2016-12-31 570. 2
## 9 2014-05-05 566. 3
# Gegenprüfung
Beispieldaten %>%
select(Datum, Umsatz) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz)) %>%
distinct(Datum) ## # A tibble: 339 x 1
## Datum
## <date>
## 1 2014-12-31
## 2 2015-12-31
## 3 2016-12-31
## 4 2018-12-31
## 5 2013-12-31
## 6 2017-12-31
## 7 2014-05-05
## 8 2013-08-03
## 9 2014-08-09
## 10 2013-07-28
## # ... with 329 more rows
Für acht Daten ergibt sich, dass für diese mehrere Umsätze für einen Tag eingetragen wurden:
- 2013-08-11: 666.91€ (WG 2), 583.49 € (WG 5)
- 2013-12-31: 586.13€ (WG 2), 1625.69€ (WG 5)
- 2014-05-05: 1203.43€ (WG 2), 565.94€ (WG 3), 749.22€ (WG 5)
- 2014-12-31: 643.37€ (WG 2), 1879.46€ (WG 5)
- 2015-12-31: 643.67€ (WG 2), 1869.94€ (WG 5)
- 2016-12-31: 569.61€ (WG 2), 1705.14€ (WG 5)
- 2018-06-23: 706.42€ (WG 2), 662.37€ (WG 5)
- 2018-12-31: 618.31€ (WG 2), 1668.12€ (WG 5)
Auch die Über- bzw. Gegenprüfung bestätigt dies: es gibt nur 339 nicht doppelte Fälle gibt.
Anzahl der der Ausreißer pro Jahr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ENDE potentielle Einfügung !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Zusammenfassung der Erkenntnisse:
- Warengruppe 2 (Brötchen) ist mit großem Abstand die Warengruppe mit den meisten Ausreißern, diese sind in jedem Jahr überwiegend in der Sommerfereinzeit zu verzeichnen. Weitere Ausreißer gibt es in Warengruppe 5 (Kuchen). Die Ausreißer der WG 5 sind insbesondere an Silvester zu beobachten. Einen einzelnen Ausreißer gibt es in der WG 3 (Croissant) am 05.05.2014.
- Die Struktur der Verteilung der Ausreißer ist in allen Jahren ähnlich, hat jedoch gewisse Abweichungen in den einzelnen Jahren (vgl. bspw. die Verteilung der Ausreißer in den Jahren 2014 und 2017). Was die Anzahl Ausreißer insgesamt pro Jahr anbelangt, gibt es deutliche Schwankungen. Dies sollte ggf. bei den weitergehenden Analysen noch einmal gesondert berücksichtigt werden.
- Die Sommerferien (der Tourismus) scheinen einen signifikanten Einfluss auf den Umsatz zu haben; dies gilt nicht für die übrigen Ferien des Jahres. Allerdings scheint es ebenfalls entscheidend zu sein, wie die Sommerferien in den einzelnen Bundesländern liegen (starten die Fereien vglw. früh oder eher spät, gibt es Überschneidungen bei großen BuLä, wie lange dauern diese Überschneidungen an)
- Das Wochenende ist insgesamt ebenfalls ein bedeutender Einflussfaktor; dieser Effekt beschränkt sich jedoch zeitweise nur auf den Sonntag (je nach Jahreszeit).
- Die Kieler Woche beeinflusst die Umsätze der betrachteten Filiale in einzelnen Jahren des betrachteten Zeitraums maßgeblich, der Effekt ist jedoch nicht allzu groß.
- Feiertage haben nur teilweise einen bedeutsamen Einfluss auf den Umsatz (Ostern, Christi Himmelfahrt, Pfingsten, Tag der Deutschen Einheit, Silvester, nicht jedoch Weihnachten); andere Feiertage wie der Reformationstag haben keinen Einfluss.
- Die stärksten Ausreißer eines jeden der betrachteten Jahre sind jeweils an Silvester zu verzeichnen.
Als nächstes wird der Datensatz Wetter auf Ausreißer hin überprüft:
Die Variable Windgeschwindigkeit enthält 7 Ausreißer.
….
2.7 Deskriptive Statistik
## Warengruppe
## 1 2 3 4 5 6
## 272046.42 874857.56 364835.24 184680.16 605741.79 23386.15
## Warengruppe
## 1 2 3 4 5 6
## 125.13635 402.41838 167.81750 87.11328 278.63008 67.20159
## # A tibble: 6 x 2
## Warengruppe n
## <dbl> <int>
## 1 1 2174
## 2 2 2174
## 3 3 2174
## 4 4 2120
## 5 5 2174
## 6 6 348
## # A tibble: 6 x 3
## Warengruppe min_dat max_dat
## <dbl> <date> <date>
## 1 1 2013-07-01 2019-07-30
## 2 2 2013-07-01 2019-07-30
## 3 3 2013-07-01 2019-07-30
## 4 4 2013-07-01 2019-07-30
## 5 5 2013-07-01 2019-07-30
## 6 6 2013-10-24 2018-12-28
Für die Warengruppen 1, 2, 3 und 5 gibt es jeweils 2.174 Datensätze, für die Warengruppe 4 sind es 2.120 Datensätze. Auffällig ist, dass es für die Warengruppe 6 nur 348 Datensätze gibt.
Die Datensätze für die ersten 5 Warengruppen erstrecken sich über denselben Zeitraum: 1.7.2013 bis 30.7.2019. Die erste Vermutung war, dass für die 6. Warengruppe nur ein eingeschränkter Zeitraum zur Verfügung steht. Dieser Verdacht wird widerlegt: Der Zeitraum der Daten für die 6. Warengruppe ist nur geringfügig kürzer und geht vom 24.10.2013 bis 28.12.2018.
Entscheidung: Die Warengruppe 6 wird in der Modellierung nicht betrachtet.
Welches sind die 20 umsatzstärksten Tage des Jahres (Gesamtumsatz pro Tag)?
Beispieldaten %>%
select(Datum, Umsatz) %>%
group_by(Datum) %>%
summarise(Gesamtumsatz = sum(Umsatz)) %>%
arrange(desc(Gesamtumsatz)) %>%
top_n(20)## Selecting by Gesamtumsatz
## # A tibble: 20 x 2
## Datum Gesamtumsatz
## <date> <dbl>
## 1 2014-05-05 3156.
## 2 2015-12-31 3015.
## 3 2014-12-31 2939.
## 4 2018-12-31 2805.
## 5 2016-12-31 2773.
## 6 2013-12-31 2615.
## 7 2017-12-31 2378.
## 8 2014-08-18 2121.
## 9 2014-06-28 2096.
## 10 2019-06-29 2035.
## 11 2013-08-03 2022.
## 12 2016-08-13 2014.
## 13 2014-08-24 1989.
## 14 2019-04-20 1988.
## 15 2018-06-23 1987.
## 16 2014-08-23 1975.
## 17 2014-08-09 1958.
## 18 2018-08-18 1950.
## 19 2017-04-15 1950.
## 20 2014-08-16 1934.
Welches sind die 10 umsatzstärksten Tage des Jahres je Warengruppe? ÄNDERN!
3 Datenaufbereitung, Erstellung von Rohdatensatz und Analysedatensätzen
3.1 Umgang mit Ausreißern
Zwei der 7 verbleibenden Variablen enthalten Ausreißer: Umsatz und Windgeschwindigkeit. Beim Umgang mit den vorhandenen Ausreißern muss differenziert werden, ob es sich um unerwartete / nicht prognostizierbare Ausreißer handelt oder ob diese in gewisser Hinsicht planbar sind, weil sie erwartbar sind, da sie in allen Jahren gleichermaßen zu beobachten sind (z. B. Silvester).Prognostizierbare Ausreißer werden im weiteren Verlauf kodiert, d. h. es werden Variablen für diese planbaren Ausreißer angelegt.
Was die vorliegenden Daten anbelangt, sind einzig die Umsätze am Montag, 05.05.2014 auf den ersten Blick nicht zu erklären. Dieser Tag ist der umsatzstärkste Tag im gesamten Zeitverlauf. Zudem ist es der einzige Tag im gesamten Datensatz, bei dem es Ausreißer für drei Warengruppen gibt (ansonsten beschränken sich die Ausreißer weitestgehend auf Warengruppe 2, vereinzelt gibt es Tage, an denen auch Warengruppe 5 Ausreißer aufweist, z. B. an Silvester).
Bei genauerem Hinsehen haben wir festgestellt, dass für die beiden Vortage 03.05.2014 und 04.05.2014 keine Umsatzdaten vorliegen und zwar für alle Warengruppen. Der Verdacht liegt nahe, dass die Umsätze für den Zeitraum 03.-05.05.2014 summiert für den 05.05.2014 angesetzt wurden. Wir finden nämlich für den 05.05.2014 insgesamt einen Umsatz in Höhe von 3.156. Für den Vergleichszeitraum eine Woche später (10.-12.05.2014) finden wir einen Gesamtumsatz in vergleichbarer Höhe: 3.267. Es handelt sich bei keinem der Tage um einen Feiertag.
Wir korrigierten die Werte für den Zeitraum 03.-05.05.2014 und setzen dafür vereinfachend die Werte der Folgewoche ein. Wir erstellen einen Datensatz df als Kopie der Beispieldaten. Dann löschen wir zunächst den 05.05.2014, laden die korrigierten Werte für den 03.-05.05.2014 aus dem Datensatz Beispieldaten_Korrektur.csv und verknüpfen ihn mit df.
Beispieldaten %>%
group_by(Datum) %>%
filter(Datum=="2014-05-05") %>%
summarise(Summe_Umsatz=sum(Umsatz))## # A tibble: 1 x 2
## Datum Summe_Umsatz
## <date> <dbl>
## 1 2014-05-05 3156.
Beispieldaten %>%
filter(Datum >= "2014-05-10" & Datum <= "2014-05-12") %>%
group_by(Datum) %>%
summarise(Summe_Umsatz=sum(Umsatz))## # A tibble: 3 x 2
## Datum Summe_Umsatz
## <date> <dbl>
## 1 2014-05-10 1209.
## 2 2014-05-11 1192.
## 3 2014-05-12 867.
# erzeuge df vor Korrektur der Beispieldaten
df <- Beispieldaten
# entferne alte Werte für den 05.05.2014
df <- df %>% filter(Datum != "2014-05-05")
# lese korrigierte Datensätze ein und füge Attribut Jahr hinzu
Beispieldaten_korr <- read_csv("data/Beispieldaten_Korrektur.csv")## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Warengruppe = col_double(),
## Umsatz = col_double()
## )
Beispieldaten_korr <- Beispieldaten_korr %>% mutate(Jahr = year(Datum))
# verknüpfe df mit den korrigierten Datensätzen
df <- rbind(df, Beispieldaten_korr)
df %>% filter(Datum == "2014-05-05")## # A tibble: 5 x 4
## Datum Warengruppe Umsatz Jahr
## <date> <dbl> <dbl> <dbl>
## 1 2014-05-05 1 118. 2014
## 2 2014-05-05 2 329. 2014
## 3 2014-05-05 3 124. 2014
## 4 2014-05-05 4 67.5 2014
## 5 2014-05-05 5 229. 2014
Da die anderen Ausreißer durch jeweilige Sondereffekte zu erklären sind (Wochenende, Feiertag, Brückentag etc.) werden diese Ausreißer im Datensatz belassen und im Fortgang hierfür gesonderte Variablen angelegt.
3.2 Umgang mit Warengruppe 6
Die Anzahl der Datensätze je Warengruppe differiert teilweise stark, insbesondere Warengruppe 6 ist auffällig:
- Warengruppen 1, 2, 3 und 5: jeweils 2.174 Datensätze
- Warengruppe 4: 2.120 Datensätze
- Warengruppe 6: 348 Datensätze.
Die Datensätze der Warengruppe 6 werden infolgedessen gelöscht:
Nach dem Löschen der Datensätze enthält der Datensatz nunmehr 10826 Zeilen.
3.3 Rohdaten mit vollständiger Zeitreihe
Zunächst wird ein weiterer Datensatz df_voll erstellt, der eine komplette Zeitreihe enthält vom 1.7.2013 bis 31.7.2019 für alle Warengruppen 1 bis 5. Dabei wird in Kauf genommen, dass dieser zunächst viele fehlende Werte enthalten wird, die im weiteren Verlauf für die einzelnen Modelle sinnvoll zu ergänzen sind:
3.4 Vereinigung der Datensätze
Bei der Untersuchung der Datumsvariablen der einzelnen Datensätze ergab sich, dass diese über unterschiedliche Zeiträume reichen:
- Die Daten des Datensatzes Beispieldaten reichen vom 01.07.2013 bis zum 30.07.2019, sind aber teilweise unvollständig. Es fehlen bspw. für alle Warengruppen Daten für den Tag der Arbeit, Weihnachten, Neuhjahr etc. Weiterhin fehlen insbesondere bei der Warengruppe 4 immer wieder einzelne Daten in den Sommermonaten, vereinzelt auch an einzelnen Tagen im Herbst.
- Die Daten des Datensatzes KiWo reichen vom 16.06.2012 bis zum 30.06.2019.
- Die Daten des Datensatzes Wetter reichen vom 01.01.2012 bis zum 01.08.2019.
Maßgeblich ist für uns der Zeitraum der vollstängien Zeitreihe df_voll vom 01.07.2013 bis zum 31.07.2019. Wir fügen über ein left_join die Daten zur Kieler Woche und die Wetterdaten an.
df_voll <- left_join(df_voll, KiWo, by = "Datum")
df_voll <- left_join(df_voll, Wetter, by = "Datum")
head(df_voll)## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 NA 6 17.8
## 2 2013-07-01 2 536. 2013 NA 6 17.8
## 3 2013-07-01 3 201. 2013 NA 6 17.8
## 4 2013-07-01 4 65.9 2013 NA 6 17.8
## 5 2013-07-01 5 317. 2013 NA 6 17.8
## 6 2013-07-02 1 160. 2013 NA 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
3.5 Korrektur der Anzahl Nachkommastellen für einzelne Variablen
Die Variablen Umsatz und Temperatur enthalten jeweils vier Nachkommastellen, die als überflüssig und unsinnig erachtet werden. Die Anzahl der Nachkommstellen wird entsprechend korrigiert, wobei die Anzahl Nachkommastellen bei der Variable Umsatz auf 2 Nachkommastellen, die Variable Temperatur auf 1 Nachkommastelle gerundet wird:
df_voll <- df_voll %>%
mutate(Umsatz = round(Umsatz, 2)) %>%
mutate(Temperatur = round(Temperatur, 1))
head(df_voll)## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 NA 6 17.8
## 2 2013-07-01 2 536. 2013 NA 6 17.8
## 3 2013-07-01 3 201. 2013 NA 6 17.8
## 4 2013-07-01 4 65.9 2013 NA 6 17.8
## 5 2013-07-01 5 317. 2013 NA 6 17.8
## 6 2013-07-02 1 160. 2013 NA 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
3.6 Umgang mit fehlenden Werten
Der Datensatz KiWo enthält nur 72 Datensätze: für jedes Jahr wurde den Tagen, an denen die KiWo stattfindet, eine 1 zugeordnet. Diese Werte wurden Bei der Vereinigung der Datensätze entsprechend korrekt gemerged. Für alle anderen Daten, an denen keine KiWo ist, wurde bei der Vereinigung ein fehlender Wert (NA) automatisch erzeugt. Diese fehlenden Werte sind für die weitergehenden Analysen durch “0” zu ersetzen:
## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 0 6 17.8
## 2 2013-07-01 2 536. 2013 0 6 17.8
## 3 2013-07-01 3 201. 2013 0 6 17.8
## 4 2013-07-01 4 65.9 2013 0 6 17.8
## 5 2013-07-01 5 317. 2013 0 6 17.8
## 6 2013-07-02 1 160. 2013 0 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
Da die Variable Wettercode vglw. viele fehlende Werte hat (669) und unklar ist, wie diese fehlenden Werte sinnvoll ersetzt werden können, wird diese Variable ignoriert und eliminiert:
## # A tibble: 6 x 8
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 0 6 17.8
## 2 2013-07-01 2 536. 2013 0 6 17.8
## 3 2013-07-01 3 201. 2013 0 6 17.8
## 4 2013-07-01 4 65.9 2013 0 6 17.8
## 5 2013-07-01 5 317. 2013 0 6 17.8
## 6 2013-07-02 1 160. 2013 0 3 17.3
## # ... with 1 more variable: Windgeschwindigkeit <dbl>
3.7 Ergänzung um die Variablen Wochentag, Monat und Jahr
Ein wesentlicher Einflussfaktor für die Umsatzprognose wird der Wochentag sein, wir fügen diesen als eigene Spalte hinzu: Sonntag (1), Montag (2), … , Samstag (7). Und für die spätere Aufteilung der Daten in Training- und Testset wird das Jahr als weitere Spalte ergänzt und der Monat.
Damit die Wochentage adäquat in die späteren Modelle einfließen können, wird der Wochentag überdies als character-Variable abgespeichert.
Bsp.: Soll der Wochentag ein lineare Regressionsmodell aufgenommen werden, würde eine numerische Variable zu falschen Ergebnissen führen (wird der Wochentag um eins erhöht, erhöht sich der Umsatz um xy%). Bei einer character-Variable würde diese “dummyfiziert”. Ein Wochentag würde als Referenztag abgebildet werden und die anderen 6 Wochentage in Form von Dummyvariablen.
df_voll <- df_voll %>% mutate(Wochentag = wday(Datum))
df_voll <- df_voll %>% mutate(Jahr = year(Datum))
df_voll <- df_voll %>% mutate(Monat = month(Datum))
# Wochentag als character-Variable
df_voll <- df_voll %>% mutate(Wochentag_c = recode(Wochentag, "1" = "Sonntag", "2" = "Montag", "3" = "Dienstag", "4" = "Mittwoch", "5" = "Donnerstag", "6" = "Freitag", "7" = "Samstag"))
# Monat als character-Variable
df_voll <- df_voll %>% mutate(Monat_c = recode(Monat, "1" = "Januar", "2" = "Februar", "3" = "März", "4" = "April", "5" = "Mai", "6" = "Juni", "7" = "Juli", "8" = "August", "9" = "September", "10" = "Oktober", "11" = "November", "12" = "Dezember"))Es besteht die Möglichkeit, dass es unterhalb der Wochentag keine großen Unterschiede gibt, wohl aber zwischen Wochentagen und Wochenendtagen. Insofern wird eine weitere Variable Wochenende erstellt, die nur die beiden Ausprägungen 1 = “Wochenende” und 0 = “kein Wochenende” (“Wochentag”) hat.
3.8 Ergänzung um Sommerferienvariablen
Die Sommerferien scheinen einen starken Einfluss auf den Umsatz zu haben. Für die anderen Ferienzeiträume des Jahres gilt dies nicht. Für ausgewählte Bundesländer, namentlich Schleswig-Holstein, Nordrhein-Westfalen, Niedersachsen und Hessen wurden daher zunächst Datensätze in Excel erstellt (1 Datensatz je Bundesland). Diese Datensätze enthalten die Zeiträume der Sommerferien über die einzelnen Jahre. Diese Datensätze werden in R eingelesen und mit den anderen Daten zusammengeführt.
Die Auswahl der genannten Bundesländer erfolgte dabei anhand der Besucherzahlen / Übernachtungsvolumina in den vergangenen Jahren. Die meisten Gäste in Schleswig-Holstein kommen aus NRW, gefolgt von Niedersachsen und Schleswig-Holstein. Die Besucherzahlen aus Hessen lagen in den vergangenen Jahren etwas unterhalb derer von Niedersachsen und Schleswig-Holstein. Für Bayern und Baden-Württemberg werden zwar für die nähere Zukunft große Wachstumspotentiale prognostiziert, die Volumina waren in den betrachteten Zeiträumen jedoch gering und können daher vernachlässigt werden. Ebenso vernachlässigbar sind die übrigen Bundesländer.
## Ergänzung der Sommerferien Schleswig-Holstein
SoFeSH <- read_csv2("data/SoFe_SH.csv") # da der Separator ein ";" ist, muss read_csv2 verwendet werden
df_voll <- left_join(df_voll, SoFeSH, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienSH = replace_na(SommerferienSH, 0))
## Ergänzung der Sommerferien Nordrhein-Westfalen
SoFeNRW <- read_csv2("data/SoFe_NRW.csv")
df_voll <- left_join(df_voll, SoFeNRW, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienNRW = replace_na(SommerferienNRW, 0))
## Ergänzung der Sommerferien Niedersachsen
SoFeNDS <- read_csv2("data/SoFe_NDS.csv")
df_voll <- left_join(df_voll, SoFeNDS, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienNDS = replace_na(SommerferienNDS, 0))
# Ergänzung der Sommerferien Hessen
SoFeHE <- read_csv2("data/SoFe_HE.csv")
df_voll <- left_join(df_voll, SoFeHE, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienHE = replace_na(SommerferienHE, 0))3.10 Ergänzung um Variable Jahreszeit
Die ersten Betrachtungen und Analysen lassen darauf schließen, dass die Jahreszeiten einen Einfluss auf die Höhe des Umsatzes haben.
Die Variable Jahreszeiten kann bzw. muss dabei differenziert betrachtet werden. Zum einen besteht die Möglichkeit, Jahreszeiten als vorgegebene bzw. eigens definierte Variablen abzubilden. Dabei kann man bspw. den astronomische Eigenschaften zugrunde legen. Andererseits gibt es Modelle, die von sich heraus aus fiktive bzw. synthetische Jahreszeiten im Hintergrund ableiten.
Bsp.: Jahreszeiten können im Rahmen eines Entscheidungsbaums derart generiert werden, dass März, April, Mai zusammengefasst werden und zusätzlich aufgrund struktureller Ähnlichkeiten der September und der Oktober zu dieser (synthetischen) Jahreszeit hinzugefügt werden.
Die erste Möglichkeit soll an dieser Stelle umgesetzt werden. Die zweite Möglichkeit wird im weiteren Verlauf bei der Anwendung der unterschiedlichen Modelle relevant sein.
Anlegen einer eigens definierten Jahreszeit-Variable
Grundsätzlich unterteilen die Jahreszeiten das Jahr in verschiedene Perioden, welche sich durch charakteristische astronomische oder klimatische Eigenschaften auszeichnen. Im alltäglichen Sprachgebrauch sind damit hauptsächlich meteorologisch deutlich voneinander unterscheidbare Jahresabschnitte gemeint; in gemäßigten Breiten sind dies Frühling, Sommer, Herbst und Winter. (http://www.hrhen.de/wk/html/jahreszeiten.html, https://vschweiz.ch/jahreszeitenbeginn/)
Legt man astronomische Jahreszeitenanfänge für die Erstellung einer ersten Jahreszeit-Variable zugrunde, sind folgende Daten zu berücksichtigen:
| Jahr | Frühling | Sommer | Herbst | Winter |
|---|---|---|---|---|
| 2013 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2014 | 20. März | 21. Juni | 23. September | 22. Dezember |
| 2015 | 20. März | 21. Juni | 23. September | 22. Dezember |
| 2016 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2017 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2018 | 20. März | 21. Juni | 23. September | 21. Dezember |
| 2019 | 20. März | 21. Juni | 23. September | 22. Dezember |
Es gibt wiederum zwei Möglichkeiten, die Variable anzulegen:
- Anlegen einer Variable mit allen Jahreszeiten
- Je eine Variable pro Jahreszeit
Zunächst wird eine Variable für alle Jahreszeiten erstellt bzw. eingelesen und an den bestehenden Rohdatensatz hinzugefügt:
## Using ',' as decimal and '.' as grouping mark. Use read_delim() for more control.
## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Jahreszeit = col_character()
## )
In einem weiteren Schritt werden für die einzelnen Jahreszeiten eigene Variablen angelegt und mit dem bestehenden Rohdatensatz verknüpft:
## Using ',' as decimal and '.' as grouping mark. Use read_delim() for more control.
## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Fruehling = col_double()
## )
df_voll <- left_join(df_voll, Fruehling, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Fruehling = replace_na(Fruehling, 0))
## Hinzufügen der Variable Sommer
Sommer <- read_csv2("data/Sommer.csv")## Using ',' as decimal and '.' as grouping mark. Use read_delim() for more control.
## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Sommer = col_double()
## )
df_voll <- left_join(df_voll, Sommer, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Sommer = replace_na(Sommer, 0))
## Hinzufügen der Variable Herbst
Herbst <- read_csv2("data/Herbst.csv")## Using ',' as decimal and '.' as grouping mark. Use read_delim() for more control.
## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Herbst = col_double()
## )
df_voll <- left_join(df_voll, Herbst, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Herbst = replace_na(Herbst, 0))
## Hinzufügen der Variable Winter
Winter <- read_csv2("data/Winter.csv")## Using ',' as decimal and '.' as grouping mark. Use read_delim() for more control.
## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Winter = col_double()
## )
3.11 vollständige Datenreihe, Imputationen, Trainingsdaten, Testdaten
vollständige Datenreihe
Ergebnis der vorangegegangenen Operationen ist der Datensatz df_voll, der eine vollständige Zeitreihe vom 01.07.2013 bis 31.07.2019 für die Warengruppen 1 bis 5 enthält, angereichert um zahlreiche Variablen wir Kieler Woche, Wetterdaten, Sommerferien, Feiertage.
In diesem Datensatz fehlen teilweise die Umsätze für einzelne Tage und/oder Warengruppen, weil die Rohdaten fehlende Werte aufweisen.
Der Datensatz df_voll kann für einzelne Analysen ohne Weiteres verwendet werden, z. B. für eine Regressionsanalyse. Möchte man Vorhersagen auf Basis der Vorwochenwerte durchführen, z. B. die Umsatz-Prognose für den aktuellen Montag auf Basis des vorangegangenen Montags durchführen, könnten Probleme auftreten, da der Vorwochenwert aufgrund der unterbrochenenen Zeitreihe ggf. nicht verfügbar ist.
Imputation: Ergänzung fehlender Werte
Fehlende Daten sind im Datensatz df_voll mit NA gefüllt. Das bereitet für die Anwendung u.a. der naiven Modelle Probleme: Wenn bspw. der Umsatz auf Basis des Vorwochenwertes geschätzt werden soll, dann wird ein “sinnvoller” Umsatz für jedes Datum erwartet.
Zuerst kennzeichnen wir im Datensatz df_voll die Zeilen, die fehlende Umsatzwerte aufweisen mit einem neuen Attribut “Umsatz_NA”, das die Werte TRUE (Umsatz fehlt in den Rohdaten und wurde ergänzt) und FALSE (Umsatz vorhanden in den Rohdaten) annimmt.
Danach wollen wir diese fehlenden Umsätze durch Werte aus der Vergangenheit ersetzen. In der Regel gucken wir uns die Umsätze der Vorwoche an dem entsprechenden Wochentag an. Eine Ausnahme machen wir für die fehlenden Umsätze an Silvester und Neujahr: Da die Vorwochenwerte erhöht sind (Heiligabend) bzw. fehlen, gehen wir 4 Wochen zurück, weil die ersetzten Werte dann als Schätzer bspw. für die Folgewoche verwendet werden sollen.
# ergänze Attribut Umsatz_NA
df_voll <- df_voll %>% mutate(Umsatz_NA=is.na(Umsatz))
# Ergänze Spalten für den Umsatz vor 1 Woche (Umsatz_lag_1W), 2 Wochen (Umsatz_lag_2W), 3 Wochen (Umsatz_lag_3W) und 4 Wochen (Umsatz_lag_4W).
# WICHTIG: Pro Woche müssen wir 7*5=35 Datensätze zurück gehen (7 Tage mal 5 Warengruppen)
df_voll <- df_voll %>% mutate(Umsatz_lag_1W=lag(Umsatz,n=35))
df_voll <- df_voll %>% mutate(Umsatz_lag_2W=lag(Umsatz,n=2*35))
df_voll <- df_voll %>% mutate(Umsatz_lag_3W=lag(Umsatz,n=3*35))
df_voll <- df_voll %>% mutate(Umsatz_lag_4W=lag(Umsatz,n=4*35))Fehlende Umsätze (Umsatz_NA = TRUE) werden dann ersetzt durch den Vorwochenwert (Umsatz_lag_1W). Falls der Wert ebenfalls fehlt, gehen wir 2 Wochen zurück (Umsatz_lag_2W). Und falls der Wert ebenfalls fehlt, gehen wir 3 Wochen zurück (Umsatz_lag_3W). Eine Ausnahme bilden Silvester und Neujahr (Silvester_ext=1): In diesem Fall wollen wir den fehlenden Umsatz aus dem Wert vor 4 Wochen nehmen (Umsatz_lag_4W).
Der ersetzte Wert wird in einer separaten Variable “Umsatz_lag” gespeichert:
# Ergänze Attribut Umsatz_lag für den Vorwochen-Umsatz mit Initialwert 0.
df_voll <- df_voll %>% mutate(Umsatz_lag = 0)
# nicht Silvester / Neujahr: Dann nehme Umsatz der Vorwoche
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_1W * Umsatz_NA * !Silvester_ext)
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# Silvester / Neujahr: Dann nehme Umsatz von vor 4 Wochen
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_4W * Umsatz_NA * Silvester_ext)
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# prüfe: Wo fehlte noch Umsatz in den Rohdaten (Umsatz_NA = TRUE) den wir nicht ersetzen konnten aus Umsatz_lag_1W und Umsatz_lag_4W (Umsatz_lag = 0)? und Umsatz_lag = 0?
df_voll %>% filter(Umsatz_NA & (Umsatz_lag==0))## # A tibble: 3 x 39
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-08-05 4 NA 2013 0 0 25.8
## 2 2014-12-25 4 NA 2014 0 7 3.1
## 3 2014-12-26 4 NA 2014 0 6 0
## # ... with 32 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_lag_temp <dbl>
# Nehme für diese Fälle den Umsatz vor 2 Wochen (Umsatz_lag_2W)
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_2W * (df_voll$Umsatz_NA & df_voll$Umsatz_lag == 0))
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# prüfe: Wo fehlte noch Umsatz in den Rohdaten (Umsatz_NA = TRUE), der nicht ersetzt werden konnte (Umsatz_lag = 0)?
df_voll %>% filter(Umsatz_NA & (Umsatz_lag==0))## # A tibble: 0 x 39
## # ... with 39 variables: Datum <date>, Warengruppe <dbl>, Umsatz <dbl>,
## # Jahr <dbl>, KielerWoche <dbl>, Bewoelkung <dbl>, Temperatur <dbl>,
## # Windgeschwindigkeit <dbl>, Wochentag <dbl>, Monat <dbl>,
## # Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_lag_temp <dbl>
Führe nun den Umsatz aus den Rohdaten (Umsatz) zusammen mit den aus den Vorwochen ermittelten fehlenden Werten (Umsatz_lag).
Trainings- und Testdaten
Wir verwenden den Zeitraum 2014 bis 2017 als Trainingsdaten. Die Daten des Jahres 2018 dienen als Testdaten. Dafür werden weitere Datensätze erstellt. Die Datensätze df_train und df_test basieren auf dem vollstängigen Datensatz df_voll. Der vollständige Datensatz enthält die komplette Zeitreihe vom 01.07.2013 bis 31.07.2019, jedes Datum und jede Warengruppe ist enthalten. Eventuell fehlende Umsätze sind aus den Vorwochen ergänzt. Zeilen, bei denen der Umsatz ergänzt wurden, sind erkennbar am Attribut “Umsatz_NA”, die TRUE ist, wenn in den Rohdaten der Umsatz fehlte.
4. Deskriptive Analysen
4.1 Umsatz je Wochentag / Warengruppe
Untersuche den Umsatz je Wochentag und/oder Warengruppe in den Daten. Als Basis verwenden wir die zunächst den vollständigen Datensatz df_voll.
## # A tibble: 5 x 2
## Warengruppe Umsatz_sum
## <dbl> <dbl>
## 1 1 277596.
## 2 2 890675.
## 3 3 370967.
## 4 4 192355.
## 5 5 617014.
## # A tibble: 7 x 2
## Wochentag_c Umsatz_sum
## <chr> <dbl>
## 1 Dienstag 304703.
## 2 Donnerstag 315295.
## 3 Freitag 318081.
## 4 Mittwoch 303614
## 5 Montag 313530.
## 6 Samstag 390812.
## 7 Sonntag 402571.
## # A tibble: 35 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochentag_c Umsatz_sum
## <dbl> <chr> <dbl>
## 1 1 Dienstag 38815.
## 2 1 Donnerstag 44083.
## 3 1 Freitag 41408.
## 4 1 Mittwoch 37845
## 5 1 Montag 43193.
## 6 1 Samstag 47593.
## 7 1 Sonntag 24659.
## 8 2 Dienstag 112113.
## 9 2 Donnerstag 115419.
## 10 2 Freitag 117023.
## # ... with 25 more rows
## # A tibble: 35 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochentag Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 1 24659.
## 2 1 2 43193.
## 3 1 3 38815.
## 4 1 4 37845
## 5 1 5 44083.
## 6 1 6 41408.
## 7 1 7 47593.
## 8 2 1 168796.
## 9 2 2 114975.
## 10 2 3 112113.
## # ... with 25 more rows
## # A tibble: 10 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochenende Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 0 205343.
## 2 1 1 72252.
## 3 2 0 570332.
## 4 2 1 320343.
## 5 3 0 236159.
## 6 3 1 134809.
## 7 4 0 123959.
## 8 4 1 68396.
## 9 5 0 419431.
## 10 5 1 197583.
- Warengruppe 2 zeigt den höchsten Umsatz insgesamt, gefolgt von Warengruppe 5.
- Die Wochentage Samstag und Sonntag sind mit leichtem Abstand die umsatzstärksten Tage, aggregiert über alle Warengruppen.
- Für die einzelnen Warengruppen zeigt sich ein differenzierteres Bild: Für Brot (Warengruppe 1) sind bspw. Donnerstag und Samstag die umsatzstärksten Wochentage. Auch der Montag ist in dieser Woche überdurchschnittlich stark im Vergleich zu den anderen Warengruppen.
- Vergleicht man die Wochenendumsätze mit den Umsätzen der Wochentag, so ergibt sich folgendes Bild:
- 26% der Umsätze der Warengruppe 1 (Brot) werden am Wochenende erzielt, 74% an den Wochentagen
- 36% der Umsätze der Warengruppe 2 (Brötchen) werden am Wochenende erzielt, 64% unter der Woche.
- 37% der Umsätze der Warengruppe 3 (Croissants) werden am Wochenende erzielt, 63% an den Wochentagen.
- 36% der Umsätze der Warengruppe 4 (Konditorei) werden am Wochenende erzielt, 64% unter der Woche.
- 32% der Umsätze der Warengruppe 5 (Kuchen) werden am Wochenende erzielt, 68% unter der Woche. ==> demnach scheint es für die einzelnen Warengruppen abweichende Wochenend-Effekte geben. Kuchen und Brot werden im Verhältnis zu den anderen Warengruppen am Wochenende weniger verkauft.
4.2 Umsatz je Monat / Warengruppe
In einem weiteren Schritt werden die Umsätze je Warengruppe und Monat untersucht, um eine differenziertere Verteilung der Umsätze im Jahresverlauf zu erhalten.
## # A tibble: 60 x 3
## # Groups: Warengruppe [5]
## Warengruppe Monat Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 1 20130.
## 2 1 2 18439.
## 3 1 3 22556.
## 4 1 4 23667.
## 5 1 5 22545
## 6 1 6 24037.
## 7 1 7 31048.
## 8 1 8 27465.
## 9 1 9 22756.
## 10 1 10 22876.
## # ... with 50 more rows
## # A tibble: 60 x 3
## # Groups: Warengruppe [5]
## Warengruppe Monat_c Umsatz_sum
## <dbl> <chr> <dbl>
## 1 1 Juli 31048.
## 2 1 August 27465.
## 3 1 Juni 24037.
## 4 1 April 23667.
## 5 1 Oktober 22876.
## 6 1 September 22756.
## 7 1 März 22556.
## 8 1 Mai 22545
## 9 1 Dezember 21791.
## 10 1 November 20284.
## # ... with 50 more rows
- Es gibt erkennbare Unterschiede zwischen den Warengruppen, was den Umsatz pro Monat anbelangt:
- In den Warengruppen 1 - 3 (und mit Einschränkung Warengruppe 5) sind die Monate Juli, August und Juni die Top 3-Monate sind,
- Bei Warengruppe 4 liegen diese Monate auf den Plätzen 3 (August), 6 (Juli) und 11 (Juni). In dieser Waregngruppe ist der Februar der umsatzstärkste Monat, gefolgt von Oktober, der bei den anderen WG eher im Mittelfeld liegt (Platz 4 - 6). Die Warengruppe 4 verhält sich bei der Verteilung der Umsätze im Monatsverlauf also deutlich anders als die anderen Warengruppen.
- Tendenziell sind die Umsätze in den Wintermonaten (Dezember, Januar, Februar) sowie im November am schwächsten (auch hier mit leichten Abweichungen bei Warengruppe 4 und 5). Die Warengruppen Konditorei und Kuchen unterscheiden sich hier, mal mehr mal weniger, von den ersten drei Warengruppen.
4.3 Umsatz im Zeitverlauf
Von Interesse ist nun die Entwicklung der Umsätze im Zeitverlauf. Wir wollen prüfen, ob eine Trendentwicklung zu beobachten ist und ob es strukturelle Brüche in den Zeitreihen gibt. Wir betrachten dafür zunächst die Entwicklung des Gesamtumsatzes pro Jahr. Als Datenbasis verwenden wir die Trainingsdaten df_train, die den Zeitraum 2014 bis 2017 umfassen und damit 4 Jahresscheiben abbilden.
## # A tibble: 4 x 2
## Jahr Umsatz
## <dbl> <dbl>
## 1 2014 428295.
## 2 2015 378659
## 3 2016 359157.
## 4 2017 356290.
Zu beobachten ist, dass der Jahresumsatz von 2014 bis 2016 sukzessive sinkt und dann 2017 stabil bleibt. Um diese Beobachtung besser zu verstehen, betrachten wir den Umsatz nun auf Monatsebene, immer noch aggregiert über alle Warengruppen.
umsatz_jahr_monat <- df_train %>% mutate(Jahr=as.character(Jahr)) %>% group_by(Jahr, Monat) %>% summarise(Umsatz=sum(Umsatz)) # Variable Jahr in character umgewandelt, damit im folgenden Plot eine diskrete Farbskala in der Legende gezeigt werden kann
p_umsatz_jahr_monat <- ggplot(data = umsatz_jahr_monat, aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Gesamtumsatz je Monat")
p_umsatz_jahr_monatBeobachtungen:
- Die Jahre 2016 und 2017 sind weitestgehend ähnlich im Jahresverlauf.
- Die Umsätze im Jahr 2014 sind insgesamt offenbar parallel verschoben und systematisch höher jeden Monat.
- Und der Verlauf für 2015 ist ähnlich zu 2016 und 2017, nur in den ersten 3 Monaten des Jahres scheint der Umsatz 2015 systematisch höher zu liegen.
Um dies weiter zu analysieren, betrachten wir schließlich noch den Umsatz auf Monatsebene je Warengruppe, um eventuelle Unterschiede im Verhalten der einzelnen Warengruppen aufzudecken.
Erstellung der Variablen Umsatz auf Monatsebene Warengruppe 1
p_umsatz_jahr_monat_WG1 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 1) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 1: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 2
p_umsatz_jahr_monat_WG2 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 2) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 2: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 3
p_umsatz_jahr_monat_WG3 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 3) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 3: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 4
p_umsatz_jahr_monat_WG4 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 4) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 4: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 5
p_umsatz_jahr_monat_WG5 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 5) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 5: Umsatz je Monat")Beobachtungen:
- Für die Warengruppen 1, 2, 3 und 5 zeigen sich ähnliche Effekte: Die Umsätze 2014 liegen systematisch höher. Das setzt sich bis in die ersten 3 Monate des Jahres 2015 fort. Ab April 2015 sind die Verläufe ähnlich bis Ende 2017.
- Die Warengruppe 4 ist insgesamt die umsatzschwächste Gruppe. Die Monatsumsätze sind über die Jahre 2014 bis 2017 relativ ähnlich. Eine Ausnahme bildet der Februar 2017: Hier liegen die Umsätze deutlich unter den Umsätzen der übrigen Jahre. Dafür gibt es bislang keine Erklärung.
Für die weitere Entwicklung unserer Prognosemodelle könnte es daher sinnvoll sein, dass wir uns bei den Trainingsdaten auf den Zeitraum ab April 2015 bis 2017 beschränken und die Zeit davor außer Acht lassen. Und wir behalten im Hinterkopf, dass der Februar 2017 auffällig niedrige Umsätze im Februar aufweist.
5 Anwendung naiver Modelle
5.1 Vorhaben
Wir wollen nun einige naive Modelle einsetzen, um die Umsätze je Warengruppe zu prognostizieren. Wir arbeiten dafür mit dem vollständigen Datensatz df_voll, der für jeden Tag und jede Warengruppe eine Zeile enthält. Fehlende Umsatzwerte in den Rohdaten sind durch die Vorwochenwerte ersetzt, weitere fehlenden Daten sind mit NA gefüllt.
Wir werden im folgenden verschiedene naive Prognosemodelle testen und vergleichen. Zuerst betrachten wir die Schätzung des Umsatzes auf Basis des Vorwochenwertes (Umsatz_lag_1W).
Im zweiten Teil betrachten wir die Schätzung mittels eines gleitenden Durchschnitts über die letzten 3 Tage (Umsatz_glDS_3T). Wir wissen bereits, dass der Umsatz am Wochenende systematisch höher ist, als unter der Woche. Daher erwarten wir, dass der gleitende Durchschnitt in der Form nur eingeschränkt geeignet ist, wahrscheinlich nur Für Donnerstag und Freitag. Als Erweiterung könnte man den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw), oder sogar auf Basis der letzten vier Wochentage bzw. Wochenendtage (Umsatz_glDS_4T_erw).
Und schließlich betrachten wir einen gewichteten Mittelwert der Vorwochen (Umsatz_gewMW_4W) als Schätzer. Hierbei gewichten wir den Wert der Vorwoche mit 50%, den Wert zwei Wochen zurück mit 25% und den Wert drei Wochen zurück mit 15% und den Wert vier Wochen zurück mit 10%.
Und dann werfen wir einen Blick auf die Prognose-Güte:
- Anteil an zu hoch / zu niedrig geschätzten Umsätze, ggf. je Warengruppe und/oder Wochentag
- mittlere Abweichung, mittlere absolute Abweichung, mittlere quadratische Abweichung
- Standardabweichung, Verteilung der Abweichungen
Wir wollen die naiven Modelle in ihrer Prognose-Güte vergleichen. Und wir prüfen die Top10 stärksten Abweichungen nach oben und nach unten für die verschiedenen Modelle, um rauszufinden, ob es Tage gibt, für die mehrere oder sogar alle naiven Modelle versagen.
5.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Zunächst benötigen wir Werte für folgende Attribute, die teilweise schon vorhanden sind und teilweise neu erstellt werden:
- Umsatz_lag_1W
- Umsatz_lag_2W
- Umsatz_lag_3W
- Umsatz_lag_4W
- Umsatz_gewMW_4W
- Umsatz_lag_1T bis Umsatz_lag_8T, Umsatz_lag_13T, Umsatz_lag_14T (1 bis 8, 13 und 14 Tage zurück)
- Umsatz_glDS_3T
- Umsatz_glDS_3T_erw
- Umsatz_glDS_4T_erw
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_naiv auf Basis von df_voll.
# initialisiere Datensatz
df_naiv <- df_voll
# fülle Umsatz_lag_1W mit dem Vorwochenwert (also 7 Tage mal 5 Warengruppen zurück)
df_naiv <- df_naiv %>% mutate(Umsatz_lag_1W = lag(Umsatz, n=35))
# fülle entsprechend Umsatz_lag_2W, Umsatz_lag_3W, Umsatz_lag_4W
df_naiv <- df_naiv %>% mutate(Umsatz_lag_2W = lag(Umsatz, n=70))
df_naiv <- df_naiv %>% mutate(Umsatz_lag_3W = lag(Umsatz, n=105))
df_naiv <- df_naiv %>% mutate(Umsatz_lag_4W = lag(Umsatz, n=140))
# damit können wir bereits den gewichteten Mittelwert der letzten 4 Wochen erstellen
df_naiv <- df_naiv %>% mutate(Umsatz_gewMW_4W = 0.5*Umsatz_lag_1W + 0.25*Umsatz_lag_2W + 0.15*Umsatz_lag_3W + 0.1 * Umsatz_lag_4W)
# Bereite die Berechnung des gleitenden Durchschnitts der letzten 3 Tage vor.
# Für die Berechnung des erweiterten gleitenden Durchschnitts benötigen wir weitere Tage.
df_naiv <- df_naiv %>% mutate(Umsatz_lag_1T = lag(Umsatz, n=5)) # 1 Tag zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_2T = lag(Umsatz, n=10)) # 2 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_3T = lag(Umsatz, n=15)) # 3 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_4T = lag(Umsatz, n=20)) # 4 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_5T = lag(Umsatz, n=25)) # 5 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_6T = lag(Umsatz, n=30)) # 6 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_7T = lag(Umsatz, n=35)) # 7 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_8T = lag(Umsatz, n=40)) # 8 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_13T = lag(Umsatz, n=65)) # 13 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_14T = lag(Umsatz, n=70)) # 14 Tage zurück
# nun können wir den gleitenden Durchschnitt der letzten 3 Tage erstellen
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T = (Umsatz_lag_1T + Umsatz_lag_2T + Umsatz_lag_3T) / 3)
# Dir Berechnung des erweiterten gleitenden Durchschnitt ist etwas aufwändiger: Hierfür wollen wir zuerst den Durchschnitt der letzten 3 Wochentage bzw. Wochenendtage ermitteln. Für einen Montag müssen wir also 3, 4 und 5 Tage zurück gehen, für einen Samstag 6, 7 und 13 Tage. Oder anders ausgedrückt: Der Umsatz 1 Tag zurück (Umsatz_lag_1T) fließt in die Berechnung des erweiterten Durchschnitts für die Tage Di, Mi, Do, Fr und So ein, also alle Tage außer Mo und Sa. Wir errechnen den erweiterten Durchschnitt scheibenweise:
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = 0) # initialisiere neue Variable
# speichere die 1. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Montag" & df_naiv$Wochentag_c != "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 2. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_2T * (df_naiv$Wochentag_c == "Mittwoch" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 3. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_3T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 4. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_4T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 5. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_5T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Mittwoch"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 6. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_6T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 7. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_7T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 8. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_8T * (df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 13. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_13T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# Prüfung: df_naiv %>% filter(is.na(Umsatz_glDS_3T_erw))# Wir wiederholen das Vorgehen, um noch den Durchschnitt der letzten 4 Wochentage bzw. Wochenendtage ermitteln. Für einen Montag müssen wir also 3, 4, 5 und 6 Tage zurück gehen, für einen Samstag 6, 7, 13 und 14 Tage. Oder anders ausgedrückt: Der Umsatz 1 Tag zurück (Umsatz_lag_1T) fließt in die Berechnung des erweiterten Durchschnitts für die Tage Di, Mi, Do, Fr und So ein, also alle Tage außer Mo und Sa. Wir errechnen den erweiterten Durchschnitt scheibenweise:
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = 0) # initialisiere neue Variable
# speichere die 1. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Montag" & df_naiv$Wochentag_c != "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 2. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_2T * (df_naiv$Wochentag_c == "Mittwoch" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 3. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_3T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 4. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_4T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 5. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_5T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Mittwoch"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 6. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Freitag" & df_naiv$Wochentag_c != "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 7. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_7T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 8. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_8T * (df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 13. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_13T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 14. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_14T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))Unsere Schätzung machen wir nur für Tage, für die Umsatzdaten in den Rohdaten vorlagen (Umsatz_NA = FALSE). Und für die einzelnen Modelle beginnt die Schätzung erst ab dem Zeitpunkt, ab dem Vorwochenwerte vorliegen. Für die Verwendung des gewichteten MIttelwertes der letzten 4 Wochen können wir bspw. erst ab dem 29. Tag schätzen. Alle anderen Schätzer liegen schon früher vor. Für die Vergleichbarkeit der Modelle starten wir daher einheitlich ab dem 01.08.2013 (also sogar erst 31 Tage nach Beginn der Zeitreihe).
5.3 Prognose der Umsätze anhand des Vorwochenwertes
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_lag_1W.
prog_naiv_lag_1W <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
mutate(Prognose_zuhoch = (Umsatz_lag_1W >= Umsatz)) %>%
mutate(Abweichung = Umsatz_lag_1W - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_lag_1W - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_lag_1W - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_lag_1W %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1059 49
## 2 1 TRUE 1086 51
## 3 2 FALSE 1054 49
## 4 2 TRUE 1091 51
## 5 3 FALSE 1061 49
## 6 3 TRUE 1084 51
## 7 4 FALSE 1023 49
## 8 4 TRUE 1075 51
## 9 5 FALSE 1060 49
## 10 5 TRUE 1085 51
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_lag_1W %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.0664 41.4 29.9 24
## 2 2 2145 399. 0.204 85.1 58.2 15
## 3 3 2145 166. -0.0511 45.3 32.9 20
## 4 4 2098 87.2 0.0784 32.5 23.3 27
## 5 5 2145 277. 0.354 125. 53.3 19
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_lag_1W_relAbw_hist <- ggplot(data = prog_naiv_lag_1W, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="steelblue", color="black", size=0.5) +
ggtitle("Schätzung auf Basis der Vorwoche: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_lag_1W_relAbw_dens <- ggplot(data = prog_naiv_lag_1W, aes(x = Abweichung_rel*100)) +
geom_density(fill="steelblue", color="steelblue", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der Vorwoche: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_lag_1W_relAbw_histDie Verteilung der relativen Abweichung erscheint sehr breit. Unser naiver Schätzer auf Basis des Vorwochenwertes liefert also keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_lag_1W erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 46
## 2 2 11
## 3 3 19
## 4 4 53
## 5 5 9
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 36
## 2 1 1 10
## 3 4 0 53
# Das liefert uns keine nennenswerten Erkenntnisse, Feiertage scheinen nicht die Hauptursache für die starken Abweichungen zu sein. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 7
## 2 Donnerstag 25
## 3 Freitag 8
## 4 Mittwoch 20
## 5 Montag 33
## 6 Samstag 25
## 7 Sonntag 20
Für Dienstage und Freitage scheint unser naiver Schätzer nur selten eine deutlich zu hohe Prognose zu liefern. Ansonsten sind keine Unterschiede zu erkennen.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_lag_1W %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2016-12-31 5 1705. 2016 0 7 4.9
## 2 2017-12-31 5 1432. 2017 0 7 8.2
## 3 2014-12-31 5 1879. 2014 0 6 7.4
## 4 2015-12-31 5 1870. 2015 0 7 2
## 5 2013-12-31 5 1626. 2013 0 4 5
## 6 2016-02-04 4 213. 2016 0 5 4.2
## 7 2018-12-31 5 1668. 2018 0 7 7.4
## 8 2017-04-24 1 92.5 2017 0 7 8.9
## 9 2017-05-25 4 179. 2017 0 2 18.9
## 10 2016-05-16 4 221. 2016 0 5 11.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2014-03-02 4 108. 2014 0 6 6.6
## 2 2017-01-07 1 71.7 2017 0 8 -0.5
## 3 2018-01-07 5 316. 2018 0 0 0.6
## 4 2017-04-22 1 81.4 2017 0 5 7.5
## 5 2017-01-07 5 266. 2017 0 8 -0.5
## 6 2019-01-07 5 250. 2019 0 8 5.9
## 7 2017-04-17 1 23.2 2017 0 6 6.2
## 8 2015-01-07 5 263. 2015 0 6 5.8
## 9 2014-01-07 5 211. 2014 0 7 10.4
## 10 2016-01-07 5 212. 2016 0 7 -4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des Vorwochenwertes offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Ebenso liefert das Modell für den 7. Januar konsequent zu hohe Schätzwerte, weil diese auf Basis der sehr hohen Silvester-Umsätze prognostiziert werden.
5.4 Prognose der Umsätze anhand des gleitenden Durchschnitts
In diesem Abschnitt betrachten wir die Schätzung mittels eines gleitenden Durchschnitts über die letzten 3 Tage (Umsatz_glDS_3T). Wir wissen bereits, dass der Umsatz am Wochenende systematisch höher ist, als unter der Woche. Daher erwarten wir, dass der gleitende Durchschnitt in der Form nur eingeschränkt geeignet ist, wahrscheinlich nur Für Donnerstag und Freitag.
Als Erweiterung wollen wir den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw). Und am Ende erweitern wir dieses Vorgehen sogar noch um einen Tag (Umsatz_glDS_4T_erw) und beziehen die letzten vier Wochen- bzw. Wochenendtage in die Prognose ein.
Gleitender Durchschnitt der letzten 3 Tage
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir eigene Datensätze prog_naiv_glDS_3T und prog_naiv_glDS_3T_erw bzw. prog_naiv_glDS_4T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_3T <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_3T >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_3T - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_3T - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_3T - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_3T %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1183 55
## 2 1 TRUE 962 45
## 3 2 FALSE 1047 49
## 4 2 TRUE 1098 51
## 5 3 FALSE 1008 47
## 6 3 TRUE 1137 53
## 7 4 FALSE 938 45
## 8 4 TRUE 1160 55
## 9 5 FALSE 1065 50
## 10 5 TRUE 1080 50
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_3T %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.755 41.8 30.6 25
## 2 2 2145 399. -1.99 108. 86.2 22
## 3 3 2145 166. -0.767 51.6 39.8 24
## 4 4 2098 87.2 -0.197 36.6 26.0 30
## 5 5 2145 277. -2.05 99.2 49.0 18
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_3T_relAbw_hist <- ggplot(data = prog_naiv_glDS_3T, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="red", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des gl. Durchschnitts (3 Tage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_3T_relAbw_dens <- ggplot(data = prog_naiv_glDS_3T, aes(x = Abweichung_rel*100)) +
geom_density(fill="red", color="red", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der gl. Durchschnitts (3 Tage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_3T_relAbw_histDie Verteilung der relativen Abweichung erscheint ebenfalls sehr breit. Unser naiver Schätzer auf Basis des gleitenden Durchschnitts der letzten 3 Tage liefert also keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_3T erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 132
## 2 2 1
## 3 3 19
## 4 4 60
## 5 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 4 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 113
## 2 1 1 19
## 3 4 0 59
## 4 4 1 1
# Das liefert uns keine nennenswerten Erkenntnisse, Feiertage scheinen nicht die Hauptursache für die starken Abweichungen zu sein. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 26
## 2 Donnerstag 8
## 3 Freitag 5
## 4 Mittwoch 23
## 5 Montag 38
## 6 Samstag 7
## 7 Sonntag 119
Wie erwartet funktioniert das Modell für die Tage Donnerstag und Freitag sehr gut, weil für diese Tage die Schätzung keine Wochenendtage einbezieht. Offenbar funktioniert das auch für den Samstag relativ gut. Für die übrigen Tage gibt es Probleme.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_3T %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2014-12-31 5 1879. 2014 0 6 7.4
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2013-12-31 5 1626. 2013 0 4 5
## 5 2018-12-31 5 1668. 2018 0 7 7.4
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2013-11-17 4 177. 2013 0 2 8.9
## 8 2014-02-23 4 430. 2014 0 1 8.6
## 9 2015-02-01 4 215. 2015 0 7 -0.2
## 10 2017-01-15 4 230. 2017 0 5 1.4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-04-19 1 25.5 2015 0 0 10.1
## 2 2017-01-17 4 37.2 2017 0 7 0.5
## 3 2014-02-24 4 57.8 2014 0 1 9.4
## 4 2014-04-20 1 57.8 2014 0 0 13.9
## 5 2016-01-03 5 190. 2016 0 7 -5.5
## 6 2015-11-22 1 24.8 2015 0 7 2.2
## 7 2018-04-01 1 68.3 2018 0 6 2.5
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des gleitenden Durchschnitts offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
Erweiterter gl. Durchschnitt der letzten 3 Wochen- bzw. Wochenendtage
Als Erweiterung wollen wir den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw).
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_glDS_3T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_3T_erw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_3T_erw >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_3T_erw - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_3T_erw - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_3T_erw - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1061 49
## 2 1 TRUE 1084 51
## 3 2 FALSE 1066 50
## 4 2 TRUE 1079 50
## 5 3 FALSE 1058 49
## 6 3 TRUE 1087 51
## 7 4 FALSE 996 47
## 8 4 TRUE 1102 53
## 9 5 FALSE 1052 49
## 10 5 TRUE 1093 51
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.720 43.5 32.2 26
## 2 2 2145 399. -1.34 69.2 48.2 12
## 3 3 2145 166. -0.510 35.5 25.5 15
## 4 4 2098 87.2 -0.0883 31.7 22.4 26
## 5 5 2145 277. -1.53 97.4 43.5 16
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_3T_erw_relAbw_hist <- ggplot(data = prog_naiv_glDS_3T_erw, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="yellow", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des erw. gl. Durchschnitts (3 Wochen-/Wochenendtage): Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_3T_erw_relAbw_dens <- ggplot(data = prog_naiv_glDS_3T_erw, aes(x = Abweichung_rel*100)) +
geom_density(fill="yellow", color="yellow", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der erw. gl. Durchschnitts (3 Wochen-/Wochenendtage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_3T_erw_relAbw_histDie Verteilung der relativen Abweichung erscheint deutlich schmaler. Unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 3 Wochentage (für Mo bis Fr) bzw. Wochenendtage (für Sa und So) liefert eine treffendere Umsatzprognose. Augenscheinlich gibt es aber immer noch einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_3T_erw erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 4 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 107
## 2 3 4
## 3 4 42
## 4 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Warengruppe 2 (Brötchen) taucht gar nicht auf. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 4 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 90
## 2 1 1 17
## 3 4 0 41
## 4 4 1 1
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 8
## 2 Donnerstag 8
## 3 Freitag 5
## 4 Mittwoch 7
## 5 Montag 11
## 6 Samstag 37
## 7 Sonntag 91
Das Modell funktioniert - wie erwartet - deutlich besser für alle Wochentage Mo bis Fr. Allerdings gibt es offenbar noch Schwachstellen für das Wochenende: Besonders die Schätzung für Sonntage liegt auffällig oft deutlich zu hoch.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_3T_erw %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2018-12-31 5 1668. 2018 0 7 7.4
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2013-12-31 5 1626. 2013 0 4 5
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2016-05-16 4 221. 2016 0 5 11.2
## 8 2017-04-15 1 396. 2017 0 6 8.1
## 9 2018-03-31 1 417. 2018 0 7 2.2
## 10 2019-04-20 1 382. 2019 0 0 13.1
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2017-04-23 1 54.2 2017 0 4 7.9
## 2 2015-11-22 1 24.8 2015 0 7 2.2
## 3 2017-01-08 5 206. 2017 0 8 2.2
## 4 2014-04-20 1 57.8 2014 0 0 13.9
## 5 2015-04-19 1 25.5 2015 0 0 10.1
## 6 2016-01-04 5 190. 2016 0 5 -6
## 7 2015-04-12 1 39.0 2015 0 5 12.4
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 3 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
Erweiterter gl. Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage
Als Modellerweiterung betrachten wir nun die letzten 4 Wochen- bzw. Wochenendtage und erhoffen uns davon, dass die Schätzung für den Sonntag treffsicherer wird.
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_glDS_4T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_4T_erw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_4T_erw >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_4T_erw - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_4T_erw - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_4T_erw - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1067 50
## 2 1 TRUE 1078 50
## 3 2 FALSE 1038 48
## 4 2 TRUE 1107 52
## 5 3 FALSE 1025 48
## 6 3 TRUE 1120 52
## 7 4 FALSE 980 47
## 8 4 TRUE 1118 53
## 9 5 FALSE 1036 48
## 10 5 TRUE 1109 52
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.831 38.0 28.4 23
## 2 2 2145 399. -1.58 64.5 46.0 12
## 3 3 2145 166. -0.451 34.1 24.5 15
## 4 4 2098 87.2 0.0940 28.3 20.5 23
## 5 5 2145 277. -2.31 93.0 42.2 15
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_4T_erw_relAbw_hist <- ggplot(data = prog_naiv_glDS_4T_erw, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="orange", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des erw. gl. Durchschnitts (4 Wochen-/Wochenendtage): Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_4T_erw_relAbw_dens <- ggplot(data = prog_naiv_glDS_4T_erw, aes(x = Abweichung_rel*100)) +
geom_density(fill="orange", color="orange", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der erw. gl. Durchschnitts (4 Wochen-/Wochenendtage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_4T_erw_relAbw_histDie Verteilung der relativen Abweichung erscheint ebenfalls schmal. Unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochentage (für Mo bis Fr) bzw. Wochenendtage (für Sa und So) liefert eine treffendere Umsatzprognose. Augenscheinlich gibt es aber immer noch einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_4T_erw erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 4 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 75
## 2 3 4
## 3 4 32
## 4 5 12
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Warengruppe 2 (Brötchen) taucht gar nicht auf. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 58
## 2 1 1 17
## 3 4 0 32
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 9
## 2 Donnerstag 6
## 3 Freitag 6
## 4 Mittwoch 7
## 5 Montag 19
## 6 Samstag 17
## 7 Sonntag 59
Das Modell funktioniert liefert etwas bessere Schätzungen für den Sonntag, der aber immer noch ein Problem darstellt.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_4T_erw %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2016-12-31 5 1705. 2016 0 7 4.9
## 3 2018-12-31 5 1668. 2018 0 7 7.4
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2017-12-31 5 1432. 2017 0 7 8.2
## 6 2013-12-31 5 1626. 2013 0 4 5
## 7 2017-05-25 4 179. 2017 0 2 18.9
## 8 2016-12-29 1 282. 2016 0 3 3.8
## 9 2016-05-16 4 221. 2016 0 5 11.2
## 10 2018-03-31 1 417. 2018 0 7 2.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2014-04-20 1 57.8 2014 0 0 13.9
## 2 2014-09-07 1 49.0 2014 0 5 20
## 3 2014-02-24 4 57.8 2014 0 1 9.4
## 4 2016-01-04 5 190. 2016 0 5 -6
## 5 2015-11-22 1 24.8 2015 0 7 2.2
## 6 2015-04-12 1 39.0 2015 0 5 12.4
## 7 2015-04-19 1 25.5 2015 0 0 10.1
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
5.5 Prognose der Umsätze anhand des gewichteten Vorwochendurchschnitts
Nun betrachten wir einen gewichteten Mittelwert der Vorwochen (Umsatz_gewMW_4W) als Schätzer. Hierbei gewichten wir den Wert der Vorwoche mit 50%, den Wert zwei Wochen zurück mit 25% und den Wert drei Wochen zurück mit 15% und den Wert vier Wochen zurück mit 10%.
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_gewMW_4W. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_gewMW_4W <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
mutate(Prognose_zuhoch = (Umsatz_gewMW_4W >= Umsatz)) %>%
mutate(Abweichung = Umsatz_gewMW_4W - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_gewMW_4W - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_gewMW_4W - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_gewMW_4W %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1033 48
## 2 1 TRUE 1112 52
## 3 2 FALSE 985 46
## 4 2 TRUE 1160 54
## 5 3 FALSE 1007 47
## 6 3 TRUE 1138 53
## 7 4 FALSE 977 47
## 8 4 TRUE 1121 53
## 9 5 FALSE 1000 47
## 10 5 TRUE 1145 53
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_gewMW_4W %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.189 35.4 25.4 20
## 2 2 2145 399. 0.435 79.9 58.4 15
## 3 3 2145 166. -0.120 44.3 32.8 20
## 4 4 2098 87.2 0.0487 28.5 20.3 23
## 5 5 2145 277. 0.395 104. 47.7 17
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_gewMW_4W_relAbw_hist <- ggplot(data = prog_naiv_gewMW_4W, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="purple", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des gewichteten Vorwochendurchschnitts: Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_gewMW_4W_relAbw_dens <- ggplot(data = prog_naiv_gewMW_4W, aes(x = Abweichung_rel*100)) +
geom_density(fill="purple", color="purple", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis des gewichteten Vorwochendurchschnitts: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_gewMW_4W_relAbw_histDie Verteilung der relativen Abweichung erscheint zwar breit. Aber es scheint weniger Ausreißer nach oben zu geben, als in den anderen naiven Modellen. Unser naiver Schätzer auf Basis des gewichteten Vorwochendurchschnitts liefert insgesamt keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_gewMW_4W erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 33
## 2 2 2
## 3 3 4
## 4 4 38
## 5 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 23
## 2 1 1 10
## 3 4 0 38
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 8
## 2 Donnerstag 15
## 3 Freitag 6
## 4 Mittwoch 15
## 5 Montag 14
## 6 Samstag 17
## 7 Sonntag 16
Die Schätzung auf Basis des gewichteten Durchschnitts der letzten 4 Wochen liefert offenbar für alle Wochentage wenig Ausreißer nach oben.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_gewMW_4W %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2013-12-31 5 1626. 2013 0 4 5
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2018-12-31 5 1668. 2018 0 7 7.4
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2016-02-04 4 213. 2016 0 5 4.2
## 8 2016-05-16 4 221. 2016 0 5 11.2
## 9 2015-02-06 4 220. 2015 0 2 -0.5
## 10 2016-02-06 4 192. 2016 0 7 9.4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-10-18 1 23.1 2015 0 8 11.1
## 2 2014-03-02 4 108. 2014 0 6 6.6
## 3 2018-04-02 1 43.2 2018 0 5 6.1
## 4 2017-04-22 1 81.4 2017 0 5 7.5
## 5 2017-01-07 5 266. 2017 0 8 -0.5
## 6 2019-01-07 5 250. 2019 0 8 5.9
## 7 2015-01-07 5 263. 2015 0 6 5.8
## 8 2014-01-07 5 211. 2014 0 7 10.4
## 9 2016-01-07 5 212. 2016 0 7 -4
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Ebenso liefert das Modell für den 7. Januar konsequent zu hohe Schätzwerte, weil diese - zumindest zu einem großen Teil (50%) - auf Basis der sehr hohen Silvester-Umsätze prognostiziert werden.
5.6 Vergleich der naiven Modelle
Wir wollen jetzt die Ergebnisse der verschiedenen naiven Modelle vergleichen. Und zwar beschränken wir uns auf das Jahr 2018, weil wir die späteren Modelle (lineare Regression, Support Vector Machines, Multilayer-Perceptron,…) ebenfalls für das Jahr 2018 testen werden und einen Vergleich zu den naiven Modellen herstellen wollen.
Wir haben in diesem Kapitel die folgenden Analysedatensätze verwendet und gefüllt:
- prog_naiv_lag_1W
- prog_naiv_glDS_3T
- prog_naiv_glDS_3T_erw
- prog_naiv_glDS_4T_erw
- prog_naiv_gewMW_4W
Vergleich der relativen Abweichung
Nun bringen wir die relativen Abweichungen in einem Datensatz zusammen, je Datum, Warengruppe und Modell, um damit Facetten-Plots der Dichteverteilung, Boxplots und Violinplots der Verteilungen zu erstellen.
Als Grundgerüst (Datum, Warengruppe, Jahr, Wochentag) für die gemeinsame Tabelle dient uns der ursprüngliche Datensatz df_naiv. Wir starten ab dem 01.08.2013, weil wir ab diesem Datum Schätzer für alle Modelle haben. Und wir streichen die Datensätze, für die die Umsätze in den Rohdaten fehlen.
prog_naiv_vgl_relAbw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") %>% # starte ab 01.08.2013
select(Datum, Warengruppe, Jahr, Wochentag, Wochentag_c, SommerferienSH, Feiertag) # behalte nur diese SpaltenFüge als nächstes die relativen Abweichungen an die Tabelle an:
prog_naiv_vgl_relAbw <- prog_naiv_vgl_relAbw %>%
mutate(lag_1W = prog_naiv_lag_1W$Abweichung_rel) %>%
mutate(glDS_3T = prog_naiv_glDS_3T$Abweichung_rel) %>%
mutate(glDS_3T_erw = prog_naiv_glDS_3T_erw$Abweichung_rel) %>%
mutate(glDS_4T_erw = prog_naiv_glDS_4T_erw$Abweichung_rel) %>%
mutate(gewMW_4W = prog_naiv_gewMW_4W$Abweichung_rel)Wir müssen die Tabelle noch pivotieren (pivot_longer), als Vorbereitung für den anschließenden Plot:
prog_naiv_vgl_relAbw <- prog_naiv_vgl_relAbw %>%
pivot_longer(cols=-c("Datum", "Warengruppe", "Jahr", "Wochentag", "Wochentag_c", "SommerferienSH", "Feiertag"), names_to="Modell", values_to="Abweichung_rel")Stelle nun die Verteilung der relativen Abweichung für die verschiedenen naiven Modelle in einem Plot dar, examplarisch für die Warengruppe 1:
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & Warengruppe==1) %>%
ggplot(mapping=aes(x=Abweichung_rel*100)) +
geom_density(aes(color=Modell), alpha=0.3) +
scale_color_manual(breaks = c("lag_1W", "glDS_3T", "glDS_3T_erw", "glDS_4T_erw", "gewMW_4W"), values=c("steelblue", "red", "yellow", "orange", "purple")) +
ggtitle("2018 / WG1 - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
xlim(-100, 200)## Warning: Removed 13 rows containing non-finite values (stat_density).
AUSWERTUNG: Stelle auch die übrigen WGs dar! Unterschiede?!?
Stelle nun die Verteilung der relativen Abweichung für die Wochentage dar:
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & Wochentag_c=="Montag") %>%
ggplot(mapping=aes(x=Abweichung_rel*100)) +
geom_density(aes(color=Modell), alpha=0.3) +
scale_color_manual(breaks = c("lag_1W", "glDS_3T", "glDS_3T_erw", "glDS_4T_erw", "gewMW_4W"), values=c("steelblue", "red", "yellow", "orange", "purple")) +
ggtitle("2018 / Montag - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
xlim(-100, 200)## Warning: Removed 5 rows containing non-finite values (stat_density).
AUSWERTUNG: Stelle auch die übrigen Wochentag dar! Unterschiede?!?
Um die Dichteverteilungen besser vergleichen zu können, wählen wir einen Boxplot:
# Jahr 2018, alle Wochentage und Warengruppen
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nur Montage, alle Warengruppen
# prog_naiv_vgl_relAbw %>%
# filter(Jahr == 2018 & Wochentag_c=="Montag") %>%
# ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
# geom_boxplot() + coord_flip() +
# ggtitle("2018 / Montag - Vergleich der naiven Modelle: Relative Abweichung") +
# xlab("Modell") +
# ylab("rel. Abweichung (%)") +
# ylim(-100, 200)
# Jahr 2018, nur Sonntage, alle Warengruppen
#prog_naiv_vgl_relAbw %>%
# filter(Jahr == 2018 & Wochentag_c=="Sonntag") %>%
# ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
# geom_boxplot() + coord_flip() +
# ggtitle("2018 / Sonntag - Vergleich der naiven Modelle: Relative Abweichung") +
# xlab("Modell") +
# ylab("rel. Abweichung (%)") +
# ylim(-100, 200)
# Jahr 2018, nach Wochentag, alle Warengruppen
# Wochentag_c sortiert nach Wochentag
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
mutate(Wochentag_ord = reorder(Wochentag_c,Wochentag)) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Rel. Abweichung nach Wochentag") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Wochentag_ord))## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nach Warengruppen, alle Wochentage
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Rel. Abweichung nach Warengruppe") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Warengruppe))## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nach Warengruppen, alle Wochentage, OHNE Sommerferien und OHNE Feiertage
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & SommerferienSH == 0 & Feiertag == 0) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 OHNE SoFerien u. Feiertage - Vgl. der naiven Modelle: Rel. Abw. nach Warengruppe") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Warengruppe))## Warning: Removed 7 rows containing non-finite values (stat_boxplot).
Vergleicht man die Dichteverteilungen für das Jahr 2018 insgesamt (über alle Warengruppen und Wochentage), liefert der erweiterte gleitende Durchschnitt der letzten 3 Wochen- bzw. Wochenendtage die besten Ergebnisse.
Unterteilt man die Verteilungen nach Wochentag oder Warengruppe, ergibt sich ein differenzierteres Bild:
Nach Wochentag liefert der erweiterte gleitende Durchschnitt der letzten 3 Wochen- bzw. Wochenendtage die besten Ergebnisse unter der Woche (Mo bis Fr), versagt aber an Wochenenden (Sa und So), wie wir bereits gesehen hatten. Für Samstage liefert der erweiterte gleitende Durchschnitt der letzten 4 anstatt 3 Wochen- bzw. Wochenendtage die besten Ergebnisse. Für Sonntage liefert das einfachste Modell auf Basis des Vorwochenwertes offenbar die treffendsten Schätzer.
Nach Warengruppe liefert der gleitende Durchschnitt der letzten 3 Tage die besten Ergebnisse für Warengruppe 1 (Brot). Die übrigen Warengruppen werden durch den erweiterten gleitenden Durchschnitt der letzten 3 Wochen- bzw. Wochenendtagen am besten prognostiziert.
Guckt man sich die Verteilungen nach Warengruppe OHNE Sommerferien und OHNE Feiertage an, erhält man fast identische Ergebnisse.
Vergleich der Güte-Kennzahlen
Wir wollen nun die ermittelten Güte-Kennzahlen für die verschiedenen naiven Modelle verfeinern und zusammen bringen. Dafür erstellen wir eine Vergleichstabelle (prog_naiv_vgl_kennz), die die Kennzahlen je Modell für 2018 enthält. Im ersten Schritt betrachten wir nur die Gesamtgüte für die 5 Modelle und trennen erst später nach Warengruppen und Wochentagen.
Wir möchten nun folgende Güte-Kennzahlen für die Umsatzschätzung vergleichen:
- mittlere absolute Abweichung (MAE)
- mittlere relative Abweichung (MPE)
- mittlere Absolutwert der relativen Abweichung (MAPE)
- gewichtetes Mittel des Absolutwerts der relativen Abweichung (WAPE)
- mittlere quadratische Abweichung (MSE)
- Wurzel der mittleren quadratischen Abweichung (RMSE)
Die mittlere absulute Abweichung (MAE = mean absolute error) gibt uns ein Gefühl, wie start der Schätzer vom tatsächlichen Umsatz abweicht.
Die mittlere relative Abweichung (MPE = mean percentage error) gibt uns Anhaltspunkte, ob und wir stark die Prognose eines Modells systematisch daneben liegt - in Prozent.
Der mittlere Absolutwert der relativen Abweichung (MAPE = mean absolute percentage error) verrät uns, wie stark die Schätzung im Mittel vom tatsächlichen Umsatz abweicht - in beide Richtungen - in Prozent.
Das gewichtete Mittel des Absolutwerts der relativen Abweichung (WAPE = weighted absolute percentage error) bezieht den Umsatz des Schätzers zusätzlich als Gewicht mit ein. Das Ergebnis ist ebenfalls ein Prozentwert.
Die mittlere quadratische Abweichung (MSE = mean squared error) bestraft größere Abweichungen stärker als die übrigen Kennzahlen.
Üblicherweise vergleicht man jedoch die Wurzel der mittleren quadratischen Abweichung (RMSE = root mean squared error).
Wir haben in diesem Kapitel bisher die folgenden Analysedatensätze verwendet und gefüllt:
- prog_naiv_lag_1W
- prog_naiv_glDS_3T
- prog_naiv_glDS_3T_erw
- prog_naiv_glDS_4T_erw
- prog_naiv_gewMW_4W
Diese enthalten schon:
- Abweichung: Differenz zwischen prognostiziertem und tatsächlichem Umsatz
- Abweichung_abs: Der Absolutwert der Abweichung
- Abweichung_rel: Die relative Abweichung
Wir benötigen noch weitere Hilfsgrößen:
- Abweichung_rel_abs: Der Absolutwert der relativen Abweichung
- Abweichung_rel_abs_mult_Umsatz: Das ganze noch multipliziert mit dem tatsächlichen Umsatz
# starte mit lag_1W: Ergänze die benötigten Hilfsgrößen
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_lag_1W %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "lag_1W")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- temp
# weiter mit glDS_3T: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_3T %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_3T")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit glDS_3T_erw: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_3T_erw %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_3T_erw")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit glDS_4T_erw: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_4T_erw")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit gewMW_4W: Ergänze die benötigten Hilfsgrößen
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_gewMW_4W %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "gewMW_4W")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
head(prog_naiv_vgl_kennz)## # A tibble: 5 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1789 372262 208 39 4 21 19 4660 68
## 2 1789 372262 208 44 6 24 21 4590 68
## 3 1789 372262 208 33 4 19 16 3436 59
## 4 1789 372262 208 31 4 18 15 3017 55
## 5 1789 372262 208 36 4 19 17 3793 62
## # ... with 1 more variable: Modell <chr>
Im Vergleich der Gütekennzahlen fällt auf, dass alle Modelle den Umsatz im Schnitt zu hoch schätzen und zwar um 4 bis 6% (MPE). Der erweiterte gleitende Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage (glDS_4T_erw) schneidet am besten ab - zumindest in der Gesamtsicht. Wir wollen nun die Kennzahlen für dieses Modell je warengruppe und Wochentag betrachten.
temp <- prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
temp## # A tibble: 5 x 10
## Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 358 47292 132 30 9 26 23 1723
## 2 2 358 135858 379 41 1 11 11 3235
## 3 3 358 61867 173 26 3 16 15 1242
## 4 4 357 29606 83 17 5 21 20 459
## 5 5 358 97639 273 43 2 15 16 8418
## # ... with 1 more variable: RMSE <dbl>
Wenn wir uns das Modell (glDS_4T_erw) genauer angucken, sehen wir, dass die Schätzung für die Warengruppe 2 (Brötchen) am besten funktioniert. Der Mittelwert der relativen Abweichung (MPE) liegt nahe Null. Und das gewichtete Mittel des Absolutwerts der relativen Abweichung (WAPE) zeigt die niedrigsten Werte.
Auch für Warengruppe 5 (Kuchen) liefert das Modell offenbar gute Schätzungen. Auffällig ist jedoch, dass die mittlere quadratische Abweichung (MSE) deutlich höher ist, als für die anderen Warengruppen. Das liegt vermutlich am Schätzfehler für Silvester, wird hier aber nicht weiter geprüft.
Zuletzt gucken wir uns die Gütekennzahlen für dieses Modell je Wochentag an.
temp <- prog_naiv_glDS_4T_erw %>%
group_by(Wochentag_c) %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
temp## # A tibble: 7 x 10
## Wochentag_c Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE
## <chr> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Dienstag 250 47068 188 25 5 16 13 1174
## 2 Donnerstag 260 51426 198 26 -3 15 13 1410
## 3 Freitag 255 50703 199 22 -3 13 11 925
## 4 Mittwoch 250 46145 185 22 8 16 12 815
## 5 Montag 254 50733 200 42 10 22 21 10013
## 6 Samstag 260 63057 243 39 1 18 16 3679
## 7 Sonntag 260 63130 243 42 10 26 17 3068
## # ... with 1 more variable: RMSE <dbl>
Offenbar versagt dieses Modell für Montage und Sonntage: Allein die mittlere relative Abweichung (MPE) liegt für diese beiden Tage bei 10%.
Top10 Tage der größten Abweichungen
Wir untersuchen nun die Tage mit den größten Abweichungen nach oben und unten für die verschiedenen naiven Modelle. Dabei beschränken wir uns auf das Jahr 2018, weil dieser Zeitraum auch für die anderen Modelle als Testzeitraum feststeht und wir dann die Modelle besser vergleichen können. Wir erstellen eine gemeinsame Tabelle für alle Modelle (prog_naiv_vgl_top).
Wir wollen rausfinden, ob es Tage gibt, die in allen Modellen schlecht prognostiziert werden. Für die zu niedrigen Prognosen war das vor allem der Silvester in WG5 (Kuchen = Berliner). Aber was ist mit den Tagen, an denen die Prognose zu hoch war? Den 7. Januar haben wir für einige Modelle schon erklärt. Gibt es weitere auffällige Tage? Oder führen bspw. die Sommerferien systematisch zu größeren Abweichungen?
# starte mit lag_1W: Größte rel. Abweichungen, bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_lag_1W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "lag_1W") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- temp
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_lag_1W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "lag_1W") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_3T: Größte rel. Abweichungen, bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_3T %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_3T %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_3T_erw: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_3T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T_erw") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_3T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T_erw") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_4T_erw: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_4T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_4T_erw") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_4T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_4T_erw") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit gewMW_4W: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_gewMW_4W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "gewMW_4W") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_gewMW_4W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "gewMW_4W") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)Nun wollen wir im Detail analysieren, für welche Tage der Umsatz systematisch zu hoch oder zu tief geschätzt wird durch unsere verschiedenen naiven Modelle.
prog_naiv_vgl_top %>%
group_by(Datum, Prognose) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 45 x 3
## # Groups: Datum [44]
## Datum Prognose Anzahl
## <date> <chr> <int>
## 1 2018-03-29 zu tief 10
## 2 2018-12-31 zu tief 8
## 3 2018-03-31 zu tief 5
## 4 2018-04-02 zu hoch 5
## 5 2018-06-23 zu tief 4
## 6 2018-11-10 zu hoch 4
## 7 2018-01-06 zu hoch 3
## 8 2018-02-18 zu hoch 3
## 9 2018-03-18 zu tief 3
## 10 2018-04-01 zu hoch 3
## # ... with 35 more rows
Die erste Beobachtung ist, dass einige Daten mehrfach auftauchen. Auffällig ist - wie schon bekannt - Silvester: Dieser Tag ist in jedem Jahr sehr umsatzstark und wird von den naiven Modellen auf Basis der jüngeren Vergangenheit nicht gut vorhergesagt. Und dann fällt noch der 29.03.2018 auf.
Um insgesamt besser zu verstehen, was die stark zu hohen oder zu niedrigen Schätzwerte verursacht, nehmen wir weitere Einflussfaktoren für die gefundenen Daten hinzu:
prog_naiv_vgl_top %>%
group_by(Datum, Warengruppe, Prognose) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 53 x 4
## # Groups: Datum, Warengruppe [53]
## Datum Warengruppe Prognose Anzahl
## <date> <dbl> <chr> <int>
## 1 2018-03-29 1 zu tief 5
## 2 2018-03-29 3 zu tief 5
## 3 2018-04-02 1 zu hoch 5
## 4 2018-12-31 5 zu tief 5
## 5 2018-03-31 1 zu tief 4
## 6 2018-06-23 5 zu tief 4
## 7 2018-11-10 4 zu hoch 4
## 8 2018-02-18 1 zu hoch 3
## 9 2018-04-01 1 zu hoch 3
## 10 2018-05-24 4 zu hoch 3
## # ... with 43 more rows
Jetzt sehen wir u.a., dass für den 29.03.2018 die Umsätze in den Warengruppen 1 und 3 für alle 5 naiven Modellen zu tief geschätzt wird. Und Silvester wird die Warengruppe 5 (Kuchen = Berliner) ebenfalls in allen Modelle zu tief geschätzt.
Für fast alle Daten ist die Prognose entweder konsequent zu hoch oder konsequent zu tief. Das Datum 07.01.2018 ist das einzige Datum, für das je zwei Schätzungen stark zu hoch (Warengruppe 5) bzw. stark zu niedrieg (Warengruppe 4) waren. Es handelt sich um den Tag eine Woche nach Silvester, der in den Modellen auf Basis des Vorwochendurchschnitts (lag_1W) und des gewichteten Vorwochendurchschnitts (gewDS_4W) schlecht geschätzt wird, weil die Schätzgrundlage (Silvester) verzerrt ist.
Wir prüfen nun, ob allgemein Ferien oder Feiertage für die Tage mit starken Abweichungen zwischen Schätzer und tatsächlichem Umsatz eine Rolle spielen.
prog_naiv_vgl_top %>%
group_by(Prognose, SommerferienSH) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 3 x 3
## # Groups: Prognose [2]
## Prognose SommerferienSH Anzahl
## <chr> <dbl> <int>
## 1 zu hoch 0 50
## 2 zu tief 0 47
## 3 zu tief 1 3
prog_naiv_vgl_top %>%
group_by(Prognose, Feiertag) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 4 x 3
## # Groups: Prognose [2]
## Prognose Feiertag Anzahl
## <chr> <dbl> <int>
## 1 zu tief 0 42
## 2 zu hoch 0 39
## 3 zu hoch 1 11
## 4 zu tief 1 8
Die Sommerferien in Schleswig-Holstein haben offenbar nichts mit der schlechten Schätzung zu tun. Die Feiertage hingegen schon, aber das hatten wir erwartet: Besonders Silvester hat hier einen nennenswerten Einfluss.
Als letztes gucken wir uns den Einzeltag 29.03.2018 genau an, für den die Umsätze in den Warengruppen 1 und 3 für alle 5 naiven Modellen zu tief geschätzt wird.
## # A tibble: 10 x 63
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2018-03-29 3 266. 2018 0 7 0.9
## 2 2018-03-29 1 370. 2018 0 7 0.9
## 3 2018-03-29 1 370. 2018 0 7 0.9
## 4 2018-03-29 3 266. 2018 0 7 0.9
## 5 2018-03-29 1 370. 2018 0 7 0.9
## 6 2018-03-29 3 266. 2018 0 7 0.9
## 7 2018-03-29 1 370. 2018 0 7 0.9
## 8 2018-03-29 3 266. 2018 0 7 0.9
## 9 2018-03-29 3 266. 2018 0 7 0.9
## 10 2018-03-29 1 370. 2018 0 7 0.9
## # ... with 56 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>, Abweichung_rel_abs <dbl>,
## # Abweichung_rel_abs_mult_umsatz <dbl>, Modell <chr>, Prognose <chr>
Und auch hier ist die Erklärung für den zu niedrig geschätzten Umsatz ein Feiertagseffekt: Beim 29.03.2018 handelt es sich um den Donnerstag vor Karfreitag.
Fazit naive Modelle
Wir stellen also insgesamt fest, dass unsere naiven Modelle die Umsätze auf Basis der jüngeren Vergangenheit schätzen. Stärkere Umsätze an oder vor Feiertagen werden nicht vorhergesagt. Und die Umsätze nach Feiertagen werden entsprechend zu hoch geschätzt.
Eine Verbesserung der naiven Modelle könnten wir erzielen, indem wir die Umsätze für Feiertage auf Basis der Vorjahreswerte schätzen. Das funktioniert naiv aber nur für Feiertage, die an festen Daten liegen, wie bspw. Silvester. Für Ostern funktioniert dieses naive Vorgehen nicht. Wir verzichten auf diese Modellerweiterung und widmen uns stattdessen im Folgenden statistischen Modellen und betrachten Machine Learning und Deep Learning Modelle.
6 Anwendung statistischer Modelle - Lineare Regression
6.1 Vorhaben
In einem nächsten Schritt wird mit der linearen Regression ein traditionelles statistisches Modell zur Prognose der Bäckereiumsätze eingesetzt. Die lineare Regression ist ein sehr einfacher Ansatz für das sog. “überwachte Lernen” (supervised learning). Lineare Regressionsmodelle sind insbesondere ein nützliches Werkzeug zur Vorhersage einer quantitativen Output-Variable, die in diesem Fall dem Umsatz pro Tag entspricht. Auch wenn die lineare Regression im Vergleich modernen statistischen Lernmethoden ein vergleichsweise einfaches Modell ist, ist sie immer noch weit verbreitet. Überdies dient sie als guter Ausgangspunkt für neuere Ansätze: viele neuere statistische Lernansätze können als Generalisierung oder Erweiterung der linearen Regression betrachtet werden.
Im Allgemeinen ist bei der linearen Regression zwischen der einfachen und der multiplen Regression zu unterscheiden. Während im ersten Fall nur eine einzelne Variable als Vorhersageparameter für die abhängige Variable betrachtet wird, werden bei der multiplen linearen Regression mehrere Input-Variablen in das Modell einbezogen. Da hinsichtlich der beeinflussenden Variablen Unterschiede bei den einzelnen Warengruppen zu erwarten sind, werden die Warengruppen isoliert betrachtet. Das heißt, für jede Warengruppe werden unterschiedliche Modelle angwendet und verglichen.
Insgesamt wird Vorgehen wird in mehreren Stufen untergliedert: Zunächst wird auf Basis des allumfassenden Datensatzes df_voll ein Datensatz für die Anwendung der linearen Modelle (df_lm) erstellt und dieser sodann in einen Trainings- und einen Testdatensatz aufgeteilt. In einem nächsten Schritt werden mittels sog. best subset selection und stepwise selection die in das Modell aufzunehmenden Variablen bestimmt und auf dieser Grundlage dann ein Regressionsmodell erstellt.
6.2 Datenaufbereitung
Zunächst wird ein Arbeitsdatensatzes für die Anwendung der linearen Modelle erstellt.
df_lm <- df_voll %>%
filter(Umsatz_NA == FALSE) %>%
select(-Umsatz_NA, -Umsatz_lag_1W, -Umsatz_lag_2W, -Umsatz_lag_3W, -Umsatz_lag_4W, -Umsatz_lag)
df_lm_train <- df_lm %>% filter(Jahr >= 2014 & Jahr <= 2017)
df_lm_train <- na.omit(df_lm_train)
df_lm_test <- df_lm %>% filter(Jahr == 2018)
df_lm_test <- na.omit(df_lm_test)6.2.1 Überprüfung auf lineare Abhängigkeiten der Variablen
Für die Erstellung linearer Modelle dürfen keine linearen Abhängigkeiten zwischen den einzelnen Variablen bestehen. Zunächst ist also zu prüfen, zwischen welchen Variablen lineare Abhängigkeiten bestehen:
## Model :
## Umsatz ~ Datum + Warengruppe + Jahr + KielerWoche + Bewoelkung +
## Temperatur + Windgeschwindigkeit + Wochentag + Monat + Wochentag_c +
## Monat_c + Wochenende + SommerferienSH + SommerferienNRW +
## SommerferienNDS + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt +
## Pfingsten + TDE + Silvester + Ostern_ext + ChristiHimmelfahrt_ext +
## Pfingsten_ext + Silvester_ext + Jahreszeit + Fruehling +
## Sommer + Herbst + Winter
##
## Complete :
## (Intercept) Datum Warengruppe Jahr KielerWoche
## Wochentag_cSonntag 3/2 0 0 0 0
## Monat_cSeptember -4/5 0 0 0 0
## Wochenende 3/2 0 0 0 0
## Silvester 0 0 0 0 0
## Fruehling 1 0 0 0 0
## Sommer 0 0 0 0 0
## Herbst 0 0 0 0 0
## Winter 0 0 0 0 0
## Bewoelkung Temperatur Windgeschwindigkeit Wochentag
## Wochentag_cSonntag 0 0 0 -1/2
## Monat_cSeptember 0 0 0 0
## Wochenende 0 0 0 -1/2
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Monat Wochentag_cDonnerstag Wochentag_cFreitag
## Wochentag_cSonntag 0 1 3/2
## Monat_cSeptember 1/5 0 0
## Wochenende 0 1 3/2
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## Wochentag_cMittwoch Wochentag_cMontag
## Wochentag_cSonntag 1/2 -1/2
## Monat_cSeptember 0 0
## Wochenende 1/2 -1/2
## Silvester 0 0
## Fruehling 0 0
## Sommer 0 0
## Herbst 0 0
## Winter 0 0
## Wochentag_cSamstag Monat_cAugust Monat_cDezember
## Wochentag_cSonntag 2 0 0
## Monat_cSeptember 0 -4/5 -8/5
## Wochenende 3 0 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## Monat_cFebruar Monat_cJanuar Monat_cJuli Monat_cJuni
## Wochentag_cSonntag 0 0 0 0
## Monat_cSeptember 2/5 3/5 -3/5 -2/5
## Wochenende 0 0 0 0
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Monat_cMai Monat_cMärz Monat_cNovember Monat_cOktober
## Wochentag_cSonntag 0 0 0 0
## Monat_cSeptember -1/5 1/5 -7/5 -6/5
## Wochenende 0 0 0 0
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## SommerferienSH SommerferienNRW SommerferienNDS
## Wochentag_cSonntag 0 0 0
## Monat_cSeptember 0 0 0
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## SommerferienHE Feiertag Ostern ChristiHimmelfahrt
## Wochentag_cSonntag 0 0 0 0
## Monat_cSeptember 0 0 0 0
## Wochenende 0 0 0 0
## Silvester 0 1 -1 -1
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Pfingsten TDE Ostern_ext ChristiHimmelfahrt_ext
## Wochentag_cSonntag 0 0 0 0
## Monat_cSeptember 0 0 0 0
## Wochenende 0 0 0 0
## Silvester -1 -1 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## Wochentag_cSonntag 0 0 0
## Monat_cSeptember 0 0 0
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling 0 0 -1
## Sommer 0 0 0
## Herbst 0 0 1
## Winter 0 0 0
## JahreszeitSommer JahreszeitWinter
## Wochentag_cSonntag 0 0
## Monat_cSeptember 0 0
## Wochenende 0 0
## Silvester 0 0
## Fruehling -1 -1
## Sommer 1 0
## Herbst 0 0
## Winter 0 1
Um die linearen Abhängigkeiten zu eliminieren, werden Variablen entfernt:
df_lm_train <- df_lm_train %>%
select(-Wochentag, -Monat, -Fruehling, -Sommer, -Herbst, -Winter, - Wochenende, -Silvester)
df_lm_test <- df_lm_test %>%
select(-Wochentag, -Monat, -Fruehling, -Sommer, -Herbst, -Winter, -Wochenende, -Silvester)Erneute Überprüfung:
## Model :
## Umsatz ~ Datum + Warengruppe + Jahr + KielerWoche + Bewoelkung +
## Temperatur + Windgeschwindigkeit + Wochentag_c + Monat_c +
## SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE +
## Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE +
## Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext +
## Jahreszeit
6.2.3 Überprüfung auf Multikollinearität
Bei der multiplen Regression können zwei oder mehr Prädiktorvariablen miteinander korreliert sein. Diese Situation wird als Kollinearität bezeichnet.
Es gibt eine extreme Situation, die als Multikollinearität bezeichnet wird und in der Kollinearität zwischen drei oder mehr Variablen besteht, selbst wenn kein Variablenpaar eine besonders hohe Korrelation aufweist. Dies bedeutet, dass zwischen Prädiktorvariablen Redundanz besteht.
Bei Vorhandensein von Multikollinearität wird die Lösung des Regressionsmodells instabil.
Multikollinearität kann auf zwei verschiedene Arten überprüft werden:
- Zum einen kann die Multikollinearität für einen gegebenen Prädiktor (p) bewertet werden, indem ein Score berechnet wird, der als Varianzinflationsfaktor (oder VIF) bezeichnet wird und misst, wie stark die Varianz eines Regressionskoeffizienten aufgrund der Multikollinearität im Modell aufgeblasen wird,
- zum anderen anhand der Korrelationen der Variablen untereinander.
Der kleinstmögliche Wert von VIF ist eins (Fehlen von Multikollinearität). Als Faustregel gilt, dass ein VIF-Wert, der 5 oder 10 überschreitet, ein problematisches Maß an Kollinearität anzeigt (James et al. 2014).
Bei Multikollinearität sollten die betroffenen Variablen entfernt werden, da das Vorhandensein von Multikollinearität impliziert, dass die Informationen, die diese Variable über die Antwort liefert, bei Vorhandensein der anderen Variablen redundant sind (James et al. 2014, P. Bruce und Bruce (2017)).
Erstellung eines ersten Regressionsmodells
Um eine Überprüfung auf Multikollinearität durchzuführen, wird ein Regressionsmodell erstellt, das alle unabhängigen Variablen enthält:
## Warning: package 'caret' was built under R version 3.6.3
## Loading required package: lattice
##
## Attaching package: 'caret'
## The following object is masked from 'package:purrr':
##
## lift
# Erstellung des Modells
model1 <- lm(Umsatz ~., data = df_lm_train)
# Vorhersagen
predictions <- model1 %>% predict(df_lm_test)
# Modellperformance
data.frame(
RMSE = RMSE(predictions, df_lm_test$Umsatz),
R2 = R2(predictions, df_lm_test$Umsatz)
)## RMSE R2
## 1 128.1126 0.1553063
Überprüfung auf Multikollinearität
Überprüfung mittels VIF
Die R-Funktion vif() [car package] kann genutzt werden um Multikollinearität zu erkennen:
## GVIF Df GVIF^(1/(2*Df))
## Datum 2.518491e+03 1 50.184565
## Warengruppe 1.000058e+00 1 1.000029
## Jahr 2.377247e+03 1 48.757019
## KielerWoche 2.100741e+00 1 1.449393
## Bewoelkung 1.266115e+00 1 1.125218
## Temperatur 5.203990e+00 1 2.281226
## Windgeschwindigkeit 1.070256e+00 1 1.034532
## Wochentag_c 1.120519e+00 6 1.009528
## Monat_c 1.090368e+05 11 1.694262
## SommerferienSH 4.051709e+00 1 2.012886
## SommerferienNRW 3.645067e+00 1 1.909206
## SommerferienNDS 2.919105e+00 1 1.708539
## SommerferienHE 3.613601e+00 1 1.900947
## Feiertag 1.469157e+01 1 3.832958
## Ostern 6.569844e+00 1 2.563171
## ChristiHimmelfahrt 3.435788e+00 1 1.853588
## Pfingsten 6.354540e+00 1 2.520821
## TDE 3.211526e+00 1 1.792073
## Ostern_ext 2.330821e+00 1 1.526703
## ChristiHimmelfahrt_ext 1.432010e+00 1 1.196666
## Pfingsten_ext 2.134717e+00 1 1.461067
## Silvester_ext 2.198879e+00 1 1.482862
## Jahreszeit 3.073462e+02 3 2.597794
Der VIF-Wert für die Variablen Datum und Jahr sind sehr hoch (VIF = 50.184566 respektive 48.757019). Dies könnte problematisch sein. Insofern sollten die Variablen entfernt werden. Dies würde zu einem einfacheren Modell führen, ohne die Modellgenauigkeit zu beeinträchtigen, was gut ist.
Überprüfung durch Korrelation:
Die Korrelationen nach Pearson können in R einfach über den Befehl cor() berechnet werden. Hier sollte kein Wert größer als .7 sein.
df_lm_train %>%
dplyr::select(-Datum, -Warengruppe, -Umsatz, -Wochentag_c, -Monat_c, -Jahreszeit) %>%
cor()## Jahr KielerWoche Bewoelkung
## Jahr 1.0000000000 1.481243e-03 6.967223e-02
## KielerWoche 0.0014812428 1.000000e+00 -7.789914e-05
## Bewoelkung 0.0696722322 -7.789914e-05 1.000000e+00
## Temperatur -0.0504114841 1.524147e-01 -3.735096e-01
## Windgeschwindigkeit -0.0245494704 6.172874e-04 4.373911e-02
## SommerferienSH 0.0073016442 -5.738507e-02 -1.108929e-01
## SommerferienNRW 0.0063388216 -5.959183e-02 -1.076060e-01
## SommerferienNDS 0.0045153104 5.249218e-02 -3.029125e-02
## SommerferienHE 0.0036259100 -5.616177e-02 -8.371465e-02
## Feiertag 0.0031365781 -2.269800e-02 -2.629100e-02
## Ostern 0.0006952434 -1.213463e-02 -1.996188e-02
## ChristiHimmelfahrt 0.0004909128 -8.568291e-03 -3.224250e-02
## Pfingsten 0.0006952434 -1.213463e-02 -2.363342e-02
## TDE 0.0004909128 -8.568291e-03 -1.150265e-02
## Ostern_ext 0.0003132489 -1.643164e-02 -3.091259e-02
## ChristiHimmelfahrt_ext 0.0027196909 -1.917107e-02 -9.030404e-02
## Pfingsten_ext 0.0015839032 -1.710092e-02 -2.073056e-02
## Silvester_ext 0.0068292560 -1.166823e-02 5.131835e-02
## Temperatur Windgeschwindigkeit SommerferienSH
## Jahr -0.050411484 -0.0245494704 0.007301644
## KielerWoche 0.152414687 0.0006172874 -0.057385073
## Bewoelkung -0.373509595 0.0437391073 -0.110892888
## Temperatur 1.000000000 0.0026820864 0.428741815
## Windgeschwindigkeit 0.002682086 1.0000000000 -0.021174041
## SommerferienSH 0.428741815 -0.0211740414 1.000000000
## SommerferienNRW 0.453978742 0.0055410210 0.709059431
## SommerferienNDS 0.393950319 -0.0208597121 0.432203586
## SommerferienHE 0.402605023 -0.0418055918 0.656874581
## Feiertag 0.010249500 0.0323607585 -0.050381438
## Ostern -0.025926898 0.0221418280 -0.026934540
## ChristiHimmelfahrt 0.018720489 0.0156343909 -0.019018535
## Pfingsten 0.041919874 0.0061255278 -0.026934540
## TDE 0.028645393 0.0091720235 -0.019018535
## Ostern_ext -0.035233242 0.0662279250 -0.036472350
## ChristiHimmelfahrt_ext 0.072646314 0.0481988016 -0.042552896
## Pfingsten_ext 0.062355140 -0.0033265774 -0.037957914
## Silvester_ext -0.074728936 0.0007168796 -0.025899280
## SommerferienNRW SommerferienNDS SommerferienHE
## Jahr 0.006338822 0.00451531 0.00362591
## KielerWoche -0.059591833 0.05249218 -0.05616177
## Bewoelkung -0.107605984 -0.03029125 -0.08371465
## Temperatur 0.453978742 0.39395032 0.40260502
## Windgeschwindigkeit 0.005541021 -0.02085971 -0.04180559
## SommerferienSH 0.709059431 0.43220359 0.65687458
## SommerferienNRW 1.000000000 0.39765063 0.54606341
## SommerferienNDS 0.397650635 1.00000000 0.72103546
## SommerferienHE 0.546063407 0.72103546 1.00000000
## Feiertag -0.052318872 -0.05087834 -0.04930743
## Ostern -0.027970316 -0.02720019 -0.02636036
## ChristiHimmelfahrt -0.019749899 -0.01920611 -0.01861311
## Pfingsten -0.027970316 -0.02720019 -0.02636036
## TDE -0.019749899 -0.01920611 -0.01861311
## Ostern_ext -0.037874905 -0.03683207 -0.03569485
## ChristiHimmelfahrt_ext -0.044189281 -0.04297259 -0.04164578
## Pfingsten_ext -0.039417597 -0.03833228 -0.03714875
## Silvester_ext -0.026895245 -0.02615472 -0.02534717
## Feiertag Ostern ChristiHimmelfahrt
## Jahr 0.003136578 0.0006952434 0.0004909128
## KielerWoche -0.022698005 -0.0121346342 -0.0085682905
## Bewoelkung -0.026290999 -0.0199618823 -0.0322424967
## Temperatur 0.010249500 -0.0259268984 0.0187204890
## Windgeschwindigkeit 0.032360758 0.0221418280 0.0156343909
## SommerferienSH -0.050381438 -0.0269345404 -0.0190185351
## SommerferienNRW -0.052318872 -0.0279703163 -0.0197498986
## SommerferienNDS -0.050878338 -0.0272001893 -0.0192061103
## SommerferienHE -0.049307433 -0.0263603641 -0.0186131080
## Feiertag 1.000000000 0.5346123746 0.3774909109
## Ostern 0.534612375 1.0000000000 -0.0040216550
## ChristiHimmelfahrt 0.377490911 -0.0040216550 1.0000000000
## Pfingsten 0.534612375 -0.0056955717 -0.0040216550
## TDE 0.377490911 -0.0040216550 -0.0028396990
## Ostern_ext 0.390149438 0.7384920412 -0.0054457662
## ChristiHimmelfahrt_ext 0.157198159 -0.0089982256 0.4469386754
## Pfingsten_ext 0.374061882 -0.0080265717 -0.0056675790
## Silvester_ext 0.244824641 -0.0054766558 -0.0038670781
## Pfingsten TDE Ostern_ext
## Jahr 0.0006952434 0.0004909128 0.0003132489
## KielerWoche -0.0121346342 -0.0085682905 -0.0164316385
## Bewoelkung -0.0236334214 -0.0115026452 -0.0309125884
## Temperatur 0.0419198743 0.0286453929 -0.0352332421
## Windgeschwindigkeit 0.0061255278 0.0091720235 0.0662279250
## SommerferienSH -0.0269345404 -0.0190185351 -0.0364723503
## SommerferienNRW -0.0279703163 -0.0197498986 -0.0378749055
## SommerferienNDS -0.0272001893 -0.0192061103 -0.0368320683
## SommerferienHE -0.0263603641 -0.0186131080 -0.0356948519
## Feiertag 0.5346123746 0.3774909109 0.3901494384
## Ostern -0.0056955717 -0.0040216550 0.7384920412
## ChristiHimmelfahrt -0.0040216550 -0.0028396990 -0.0054457662
## Pfingsten 1.0000000000 -0.0040216550 -0.0077124348
## TDE -0.0040216550 1.0000000000 -0.0054457662
## Ostern_ext -0.0077124348 -0.0054457662 1.0000000000
## ChristiHimmelfahrt_ext -0.0089982256 -0.0063536658 -0.0121845939
## Pfingsten_ext 0.7095895828 -0.0056675790 -0.0108688670
## Silvester_ext -0.0054766558 -0.0038670781 -0.0074159985
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## Jahr 0.002719691 0.001583903 0.0068292560
## KielerWoche -0.019171065 -0.017100919 -0.0116682256
## Bewoelkung -0.090304040 -0.020730557 0.0513183452
## Temperatur 0.072646314 0.062355140 -0.0747289361
## Windgeschwindigkeit 0.048198802 -0.003326577 0.0007168796
## SommerferienSH -0.042552896 -0.037957914 -0.0258992804
## SommerferienNRW -0.044189281 -0.039417597 -0.0268952450
## SommerferienNDS -0.042972585 -0.038332284 -0.0261547188
## SommerferienHE -0.041645776 -0.037148747 -0.0253471732
## Feiertag 0.157198159 0.374061882 0.2448246411
## Ostern -0.008998226 -0.008026572 -0.0054766558
## ChristiHimmelfahrt 0.446938675 -0.005667579 -0.0038670781
## Pfingsten -0.008998226 0.709589583 -0.0054766558
## TDE -0.006353666 -0.005667579 -0.0038670781
## Ostern_ext -0.012184594 -0.010868867 -0.0074159985
## ChristiHimmelfahrt_ext 1.000000000 -0.012680887 -0.0086523685
## Pfingsten_ext -0.012680887 1.000000000 -0.0077180612
## Silvester_ext -0.008652368 -0.007718061 1.0000000000
Einige der unabhängigen Variablen weisen starke bis mittelstarke Korrelationen auf (auf 3 Stellen gerundet):
- SommerferienSH und SommerferienNRW: 0.648
- SommerferienSH und SommerferienNDS: 0.593
- SommerferienSH und SommerferienHE: 0.688
- SommerferienNDS und SommerferienHE: 0.774
- SommerferienSH und Sommer: 0.615
- SommerferienNRW und Sommer: 0.629
- SommerferienNDS und Sommer: 0.621
- SommerferienHE und Sommer: 0.613
- Herbst und Monat: 0.699
- Winter und Monat: -0.600
- Feiertag und Ostern: 0.537
- Feiertag und Pfingsten: 0.514
- Ostern und Ostern_ext: 0.708
- Pfingsten und Pfingsten_ext: 0.690
- Silvester und Silvester_ext: 0.706
Da die Einflussvariablen mitunter stark korrelieren und die Grenze von .7 teilweise fast ankratzen, muss in Erwägung gezogen werden, auch einge der stark miteinander korrelierten Variablen zu eliminieren, da bspw. die schrittweise Regression bei Multikollinearität versagt. Zunächst werden die Tatsache, dass einzelne Variablen stark untereinander korrelieren, jedoch ignoriert. Eine sich doch als notwendig abzeichnende Eliminierung weiterer Variablen erfolgt ggf. zu einem späteren Zeitpunkt.
Umgang mit Multikollinearität
In diesem Abschnitt, wird das Modell erneut erstellt. Dieses Mal zunächst nur ohne die beiden problematischen Variablen Datum und Jahr.
df_lm_train <- df_lm_train %>% select(-Datum, -Jahr)
df_lm_test <- df_lm_test %>% select(-Datum, -Jahr)
# Modellbildung ohne die beiden Variablen
model2 <- lm(Umsatz ~., data = df_lm_train)
# Make predictions
predictions <- model2 %>% predict(df_lm_test)
# Model performance
data.frame(
RMSE = RMSE(predictions, df_lm_test$Umsatz),
R2 = R2(predictions, df_lm_test$Umsatz)
)## RMSE R2
## 1 123.8417 0.1556423
Man kann sehen, dass das Entfernen der beiden Variablen Datum und Jahr die Modellleistungsmetriken nicht sehr beeinflusst. Mit anderen Worten, die Modellgenauigkeit leidet nicht unter dem Entfernen der beiden Variablen.
6.3 Erstellung linearer Regressionsmodelle für die einzelnen Warengruppen
Laden der benötigten Pakete
Wir beginnen unsere Analyse mit dem Laden der notwendigen Pakete, die bislang noch nicht geladen wurden:
caretfür einen einfachen Machine Learning workflowleapsfür die Berechnung einer schrittweisen Regression
6.3.1 Warengruppe 1
Erstellung von Trainings- und Testdatensätzen für Warengruppe 1
df_lm_train_WG1 <- df_lm_train %>% filter(Warengruppe == "1")
df_lm_train_WG1 <- na.omit(df_lm_train_WG1)
df_lm_train_WG1 <- df_lm_train_WG1 %>% dplyr::select(-Warengruppe)
df_lm_test_WG1 <- df_lm_test %>% filter(Warengruppe == "1")
df_lm_test_WG1 <- na.omit(df_lm_test_WG1)
df_lm_test_WG1 <- df_lm_test_WG1 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen
Beste Teilmengenauswahl (“Best subset selection”)
Um die beste Teilmengenauswahl durchzuführen, passen wir für jede mögliche Kombination der p-Prädiktoren eine separate Regression der kleinsten Quadrate an. Das heißt, wir passen alle p-Modelle an, die genau einen Prädiktor enthalten, alle (p2) = p (p - 1) / 2-Modelle, die genau zwei Prädiktoren enthalten, und so weiter. Wir betrachten dann alle resultierenden Modelle mit dem Ziel, das beste zu identifizieren.
Der dreistufige Prozess zur Durchführung der Auswahl der besten Teilmenge umfasst:
Schritt 1: Bezeichne \(M_0\) das Nullmodell, das keine Prädiktoren enthält. Dieses Modell sagt einfach den Stichprobenmittelwert für jede Beobachtung voraus.
Schritt 2: Für \(k = 1,2,… p\):
- Fit alle (pk) Modelle, die genau \(k\) Prädiktoren enthalten.
- Wähle die besten unter diesen (pk) Modelle, und nenne es \(M_k\). Hier wird “beste Modelle” in der Form definiert, dass diese die kleinsten RSS oder äquivalent die größten \(R^2\) haben.
Schritt 3: Wähle aus \(M_0, .. , M_p\) ein einzelnes bestes Modell aus unter Verwendung eines kreuzvalidierten Vorhersagefehlers (cross validated prediction error), \(Cp\), \(AIC\), \(BIC\) oder adjustiertem \(R^2\).
Die Suche nach den besten Teilmengen an Prädikatorvariablen kann mithilfe von regsubsets (Teil der leaps-Bibliothek) durchgeführt werden. regsubsets identifiziert das beste Modell für eine bestimmte/festgelegte Anzahl von k Prädiktoren, wobei “das Beste” mithilfe von RSS quantifiziert wird. Die Syntax entspricht der lm-Funktion. Standardmäßig meldet regsubsets nur Ergebnisse bis zum besten Modell mit acht Variablen. Die Option nvmax kann jedoch verwendet werden, um so viele Variablen wie gewünscht zurückzugeben. Hier passen wir zu einem Modell mit 36 Variablen.
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG1, nvmax = 36)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 36
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " "*" " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " "*" " "
## 10 ( 1 ) " " " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " " " " "
## 20 ( 1 ) " " " " " " " "
## 21 ( 1 ) " " " " " " " "
## 22 ( 1 ) "*" " " " " " "
## 23 ( 1 ) " " " " " " " "
## 24 ( 1 ) " " " " " " " "
## 25 ( 1 ) "*" " " " " " "
## 26 ( 1 ) "*" " " " " " "
## 27 ( 1 ) "*" " " " " " "
## 28 ( 1 ) "*" " " " " " "
## 29 ( 1 ) "*" " " " " " "
## 30 ( 1 ) "*" "*" " " " "
## 31 ( 1 ) "*" "*" " " " "
## 32 ( 1 ) "*" "*" " " " "
## 33 ( 1 ) "*" "*" " " " "
## 34 ( 1 ) "*" "*" " " " "
## 35 ( 1 ) "*" "*" " " " "
## 36 ( 1 ) "*" "*" " " "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " "*"
## 9 ( 1 ) " " " " "*"
## 10 ( 1 ) "*" " " " "
## 11 ( 1 ) "*" "*" " "
## 12 ( 1 ) "*" "*" " "
## 13 ( 1 ) "*" "*" " "
## 14 ( 1 ) "*" "*" " "
## 15 ( 1 ) " " " " "*"
## 16 ( 1 ) "*" "*" " "
## 17 ( 1 ) "*" "*" " "
## 18 ( 1 ) "*" "*" " "
## 19 ( 1 ) "*" "*" " "
## 20 ( 1 ) "*" "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" " "
## 32 ( 1 ) "*" "*" " "
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " "*"
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " " " "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) "*" "*" "*"
## 11 ( 1 ) "*" "*" "*"
## 12 ( 1 ) "*" "*" "*"
## 13 ( 1 ) "*" "*" "*"
## 14 ( 1 ) "*" "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) "*" "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) "*" "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) "*" "*" "*"
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) " " " " "*" "*"
## 18 ( 1 ) " " " " "*" "*"
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" "*"
## 23 ( 1 ) " " " " "*" "*"
## 24 ( 1 ) " " " " "*" "*"
## 25 ( 1 ) " " " " "*" "*"
## 26 ( 1 ) " " " " "*" "*"
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " " "
## 13 ( 1 ) " " " " " " " " " "
## 14 ( 1 ) " " " " " " " " " "
## 15 ( 1 ) " " " " " " " " " "
## 16 ( 1 ) " " " " " " " " " "
## 17 ( 1 ) " " " " " " " " " "
## 18 ( 1 ) " " " " " " "*" " "
## 19 ( 1 ) " " " " " " "*" " "
## 20 ( 1 ) " " " " "*" "*" " "
## 21 ( 1 ) " " " " "*" "*" " "
## 22 ( 1 ) " " " " "*" "*" " "
## 23 ( 1 ) "*" " " "*" "*" " "
## 24 ( 1 ) "*" " " "*" "*" " "
## 25 ( 1 ) " " " " "*" "*" " "
## 26 ( 1 ) " " " " "*" "*" " "
## 27 ( 1 ) " " " " "*" "*" "*"
## 28 ( 1 ) " " " " "*" "*" "*"
## 29 ( 1 ) " " " " "*" "*" "*"
## 30 ( 1 ) " " " " "*" "*" "*"
## 31 ( 1 ) " " " " "*" "*" "*"
## 32 ( 1 ) " " "*" "*" "*" "*"
## 33 ( 1 ) " " "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) "*" " " "*" " "
## 16 ( 1 ) "*" " " "*" " "
## 17 ( 1 ) "*" " " "*" " "
## 18 ( 1 ) "*" " " "*" " "
## 19 ( 1 ) "*" " " "*" " "
## 20 ( 1 ) "*" " " "*" " "
## 21 ( 1 ) "*" " " "*" " "
## 22 ( 1 ) "*" " " "*" " "
## 23 ( 1 ) "*" " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " "*"
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " "*" " " "*"
## 10 ( 1 ) " " " " " " "*"
## 11 ( 1 ) " " " " " " "*"
## 12 ( 1 ) " " " " " " "*"
## 13 ( 1 ) " " " " "*" "*"
## 14 ( 1 ) "*" " " "*" "*"
## 15 ( 1 ) "*" " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) "*" " " "*" "*"
## 18 ( 1 ) "*" " " "*" "*"
## 19 ( 1 ) "*" " " "*" "*"
## 20 ( 1 ) " " "*" "*" "*"
## 21 ( 1 ) " " "*" "*" "*"
## 22 ( 1 ) " " "*" "*" "*"
## 23 ( 1 ) "*" " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" " " "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" " " "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " "*"
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " "*" "*"
## 10 ( 1 ) " " " " "*" "*"
## 11 ( 1 ) " " " " "*" "*"
## 12 ( 1 ) "*" " " "*" "*"
## 13 ( 1 ) "*" "*" "*" "*"
## 14 ( 1 ) "*" "*" "*" "*"
## 15 ( 1 ) "*" "*" "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " "*"
## 7 ( 1 ) " " " " "*"
## 8 ( 1 ) " " " " "*"
## 9 ( 1 ) " " " " "*"
## 10 ( 1 ) " " " " "*"
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) " " " " "*"
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) " " " " " "
## 17 ( 1 ) " " " " " "
## 18 ( 1 ) " " " " " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) "*" " " " "
## 16 ( 1 ) "*" " " " "
## 17 ( 1 ) "*" " " " "
## 18 ( 1 ) "*" " " " "
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" " " " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" " " " "
## 23 ( 1 ) "*" " " " "
## 24 ( 1 ) "*" " " " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" " "
## 32 ( 1 ) "*" "*" " "
## 33 ( 1 ) "*" "*" " "
## 34 ( 1 ) "*" "*" " "
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die erzeugte Dummy-Variable Wochentag_cSonntag ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Wochentag das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + SommerferienSH. Das beste 3-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + SommerferienSH + Ostern_ext. Und so weiter.
Man kann auch \(RSS\), \(R^2\), adjustiertes \(R^2\), \(C_p\) und \(BIC\) aus den Ergebnissen abrufen, um das beste Gesamtmodell zu bewerten. Dies wird jedoch im Abschnitt zum Vergleichen von Modellen veranschaulicht. Schauen wir uns zunächst an, wie die schrittweise Auswahl durchgeführt wird.
Schrittweise Auswahl (“Stepwise selection”)
Aus rechnerischen Gründen kann die beste Teilmengenauswahl nicht angewendet werden, wenn die Anzahl der \(p\) Prädiktorvariablen groß ist. Die Auswahl der besten Teilmenge kann auch unter statistischen Problemen leiden, wenn \(p\) groß ist. Je größer der Suchraum ist, desto höher ist die Wahrscheinlichkeit, Modelle zu finden, die in den Trainingsdaten gut aussehen, auch wenn sie möglicherweise keine Vorhersagekraft für zukünftige Daten haben. Ein enormer Suchraum kann daher zu einer Überanpassung und einer hohen Varianz der Koeffizientenschätzungen führen. Aus diesen beiden Gründen sind schrittweise Methoden, die einen weitaus eingeschränkteren Satz von Modellen untersuchen, attraktive Alternativen zur Auswahl der besten Teilmenge.
Vorwärtsauswahl
Die schrittweise Vorwärtsauswahl beginnt mit einem Modell, das keine Prädiktoren enthält und fügt dem Modell dann nacheinander Prädiktoren hinzu, bis alle Prädiktoren im Modell enthalten sind. Insbesondere wird bei jedem Schritt die Variable zum Modell hinzugefügt, die die größte zusätzliche Verbesserung der Anpassung bewirkt.
Der dreistufige Prozess der schrittweisen Vorauswahl umfasst:
Schritt 1: Bezeichne \(M_0\) das Nullmodell, das keine Prädiktoren enthält. Dieses Modell sagt einfach den Stichprobenmittelwert für jede Beobachtung voraus.
Schritt 2: Für \(k = 0,…, p - 1\):
- Betrachte alle \(p - k\)- Modelle, die die Prädiktoren in \(M_k\) mit einem zusätzlichen Prädiktor erweitern.
- Wähle das beste unter diesen \(p - k\)-Modellen aus und nenne es \(M_[_k_+_1]\). Hier wird das beste Modell als das mit dem kleinsten \(RSS\) oder dem höchstes \(R^2\) definiert.
*+Schritt 3**: Wähle aus \(M_0,..., M_p\) unter Verwendung eines kreuzvalidierten Vorhersagefehlers, \(C_p\), \(AIC\), \(BIC\) oder dem adjustierten \(R^2\) ein einzelnes bestes Modell aus.
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Rückwärtsauswahl bietet eine effiziente Alternative zur Auswahl der besten Teilmenge. Im Gegensatz zur schrittweisen Vorwärtsauswahl beginnt sie jedoch mit dem vollständigen Modell der kleinsten Quadrate, das alle \(p\) Prädiktoren enthält und entfernt dann iterativ den am wenigsten nützlichen Prädiktor nacheinander.
Der dreistufige Prozess der schrittweisen Vorauswahl umfasst:
*Schritt 1**: Bezeichne \(M_p\) das vollständige Modell, das alle p Prädiktoren enthält.
*Schritt 2:** Für \(k = p, p - 1,..., 1\)
Betrachte alle \(k\) Modelle, die alle bis auf einen der Prädiktoren in \(M_k\) enthalten für insgesamt \(k - 1\) Prädiktoren.
Wähle das beste unter den \(k\) Modellen aus und nenne es \(M_k_1\). Hier wird das beste Modell als das mit den kleinsten \(RSS\) oder den höchsten \(R^2\) definiert.
*Schritt 3**: Wähle aus \(M_0,…, Mp\) ein einzelnes bestes Modell aus unter Verwendung eines kreuzvalidierten Vorhersagefehlers, \(C_p\), \(AIC\), \(BIC\) oder adjustiertem \(R^2\).
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Bisher wurde gezeigt, wie die besten Teilmengen (Best Subset Selection) und schrittweisen Verfahren ausgeführt werden. In einem nächsten Schritt wird nun betrachtet, wie alle Modelle verglichen werden können, um das beste Modell zu ermitteln.
Um das beste Modell in Bezug auf den Testfehler auszuwählen, müssen wir diesen Testfehler schätzen. Es gibt zwei gängige Ansätze:
- Der Testfehler kann indirekt geschätzt werden, indem der Trainingsfehler angepasst wird, um die Verzerrung aufgrund von Überanpassung (Overfitting) zu berücksichtigen.
- Der Testfehler kann direkt abgeschätzt werden, indem entweder ein Validierungssatzansatz oder einen Kreuzvalidierungsansatz verwendet wird.
Wir betrachten im Folgenden beide Ansätze.
Indirekte Schätzung des Testfehlers mit \(C_p\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
Bei der Durchführung der Ansätze “beste Teilmenge” oder schrittweisen Annäherung werden die ausgewählten Modelle \(M_0,…, M_p\) basierend auf der Tatsache ausgewählt, dass sie den mittleren quadratischen Fehler (MSE) des Trainingssatzes minimieren. Aus diesem Grund und aufgrund der Tatsache, dass die Verwendung der Trainings-\(MSE\) und \(R^2\) unsere Ergebnisse beeinflusst, sollten wir diese Statistiken nicht verwenden, um zu bestimmen, welche der \(M0,…, Mp\) Modelle “das Beste” ist.
Es stehen jedoch eine Reihe von Techniken zum Anpassen des Trainingsfehlers an die Modellgröße zur Verfügung. Diese Ansätze können verwendet werden, um aus einer Reihe von Modellen mit unterschiedlicher Anzahl von Variablen auszuwählen. Diese beinhalten:
Dabei ist \(d\) die Anzahl der Prädiktoren und \(s2\) eine Schätzung der Varianz des Fehlers (\(?\))) mit jeder Antwortmessung in einem Regressionsmodell verbunden. Jede dieser Statistiken fügt dem Trainings-\(RSS\) eine Strafe hinzu, um die Tatsache auszugleichen, dass der Trainingsfehler dazu neigt, den Testfehler zu unterschätzen. Die Strafe steigt eindeutig mit zunehmender Anzahl von Prädiktoren im Modell.
Daher liefern diese Statistiken eine unvoreingenommene Schätzung der Test-MSE. Wenn wir unser Modell unter Verwendung eines Trainings- / Testvalidierungsansatzes durchführen, können wir diese Statistiken verwenden, um das bevorzugte Modell zu bestimmen. Diese Statistiken sind in der Ausgabe der Funktion regsubsets enthalten.
Im Folgenden werden diese Informationen extrahiert und aufgezeichnet.
results <- summary(best_subset_WG1)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:36,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 29
## [1] 21
## [1] 28
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass das 29-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt das 21-Variablenmodell vor und der \(C_p\) das 28-Variablen-Modell vor.
Die Variablen und Koeffizienten, die diese Modelle enthalten, können mittels der coef-Funktion verglichen werden:
## (Intercept) Wochentag_cDonnerstag Wochentag_cFreitag
## 120.84563 17.26842 11.68476
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 16.52344 25.67621 -41.71170
## Monat_cFebruar Monat_cJanuar Monat_cMai
## -19.48972 -22.12505 -10.21038
## Monat_cMärz Monat_cOktober SommerferienSH
## -10.67859 18.66359 12.89373
## SommerferienHE Feiertag Ostern
## 11.80227 117.37864 -302.32893
## ChristiHimmelfahrt Pfingsten TDE
## -196.18722 -164.10515 -188.83689
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 155.84844 22.51991 32.62646
## JahreszeitHerbst
## -18.83957
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 118.934071 19.646713 17.369164
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.769074 16.473875 25.359793
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.827731 12.156381 -17.535670
## Monat_cJanuar Monat_cMai Monat_cMärz
## -20.169486 -8.356671 -8.762999
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 14.846819 32.878099 16.958510
## SommerferienSH SommerferienNRW SommerferienNDS
## 15.399517 13.436034 12.042815
## SommerferienHE Feiertag Ostern
## 8.175215 107.216742 -292.427112
## ChristiHimmelfahrt Pfingsten TDE
## -186.328954 -154.018667 -178.648619
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 157.623977 22.780649 33.769368
## JahreszeitHerbst JahreszeitSommer
## -31.098479 -15.010203
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 118.825293 20.350780 17.413989
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.809196 16.468754 25.325633
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## -41.900226 5.685315 12.752827
## Monat_cFebruar Monat_cJanuar Monat_cMai
## -17.423048 -20.056958 -8.250150
## Monat_cMärz Monat_cNovember Monat_cOktober
## -8.652248 15.627917 33.658867
## Monat_cSeptember SommerferienSH SommerferienNRW
## 18.165993 12.323425 14.812849
## SommerferienNDS SommerferienHE Feiertag
## 13.011380 6.278762 106.744530
## Ostern ChristiHimmelfahrt Pfingsten
## -291.928268 -185.924859 -153.524727
## TDE Ostern_ext ChristiHimmelfahrt_ext
## -178.181125 157.717242 22.806196
## Pfingsten_ext JahreszeitHerbst JahreszeitSommer
## 33.841965 -31.765961 -16.033239
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG1, nvmax = 36, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG1, nvmax = 36, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 35
## [1] 28
Wenn man das optimale \(C_p\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 35-Variablen-Modell die \(C_p\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 28-Variablen-Modell vor, ähnlich dem oben beschriebenen besten Teilmengenansatz.
Wenn wir diese Modelle bewerten, sehen wir, dass die 28-Variablen Modelle die gleichen Prädiktoren enthalten.
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 118.934071 19.646713 17.369164
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.769074 16.473875 25.359793
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.827731 12.156381 -17.535670
## Monat_cJanuar Monat_cMai Monat_cMärz
## -20.169486 -8.356671 -8.762999
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 14.846819 32.878099 16.958510
## SommerferienSH SommerferienNRW SommerferienNDS
## 15.399517 13.436034 12.042815
## SommerferienHE Feiertag Ostern
## 8.175215 107.216742 -292.427112
## ChristiHimmelfahrt Pfingsten TDE
## -186.328954 -154.018667 -178.648619
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 157.623977 22.780649 33.769368
## JahreszeitHerbst JahreszeitSommer
## -31.098479 -15.010203
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 118.934071 19.646713 17.369164
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.769074 16.473875 25.359793
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.827731 12.156381 -17.535670
## Monat_cJanuar Monat_cMai Monat_cMärz
## -20.169486 -8.356671 -8.762999
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 14.846819 32.878099 16.958510
## SommerferienSH SommerferienNRW SommerferienNDS
## 15.399517 13.436034 12.042815
## SommerferienHE Feiertag Ostern
## 8.175215 107.216742 -292.427112
## ChristiHimmelfahrt Pfingsten TDE
## -186.328955 -154.018667 -178.648619
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 157.623977 22.780649 33.769368
## JahreszeitHerbst JahreszeitSommer
## -31.098478 -15.010203
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 36)
for(i in 1:36) {
coef_x <- coef(best_subset_WG1, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG1$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 1734.0414
## [2,] 1557.4956
## [3,] 1385.7611
## [4,] 1197.9912
## [5,] 1145.8014
## [6,] 1188.4607
## [7,] 1105.6298
## [8,] 1066.3385
## [9,] 1100.1184
## [10,] 1047.0326
## [11,] 1030.2300
## [12,] 1012.2062
## [13,] 971.9783
## [14,] 970.7560
## [15,] 989.0488
## [16,] 973.1633
## [17,] 966.5381
## [18,] 981.7627
## [19,] 978.1283
## [20,] 981.5321
## [21,] 969.6222
## [22,] 958.4436
## [23,] 970.8061
## [24,] 977.1518
## [25,] 970.0031
## [26,] 971.1236
## [27,] 965.5828
## [28,] 965.4502
## [29,] 960.6451
## [30,] 960.7515
## [31,] 963.9026
## [32,] 959.9479
## [33,] 958.2222
## [34,] 953.4599
## [35,] 951.7254
## [36,] 950.7286
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA,36)
# Iterationen über jede Größe i
for(i in 1:36){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG1, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG1$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass ein 36-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 22- sowie 28-Variablen-Modell scheinen vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 28-Variblen-Modell zu erhalten. Dieses Modell wird mit dem 36-Variablen-Modell verglichen.
Teilmengenauswahl für das 28-Variablen-Modell
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 118.934071 19.646713 17.369164
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.769074 16.473875 25.359793
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.827731 12.156381 -17.535670
## Monat_cJanuar Monat_cMai Monat_cMärz
## -20.169486 -8.356671 -8.762999
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 14.846819 32.878099 16.958510
## SommerferienSH SommerferienNRW SommerferienNDS
## 15.399517 13.436034 12.042815
## SommerferienHE Feiertag Ostern
## 8.175215 107.216742 -292.427112
## ChristiHimmelfahrt Pfingsten TDE
## -186.328954 -154.018667 -178.648619
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 157.623977 22.780649 33.769368
## JahreszeitHerbst JahreszeitSommer
## -31.098479 -15.010203
Die 28 Variablen sind die folgenden:
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMai
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
Insbesondere für das 28-Variablen-Modell müssen die Variablen Wochentag_c, Monat und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG1_28 <- df_lm_train_WG1 %>%
mutate(Montag=as.integer(df_lm_train_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG1$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, Jahreszeit)
df_lm_test_WG1_28 <- df_lm_test_WG1 %>%
mutate(Montag=as.integer(df_lm_test_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG1$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 28-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG1_28_train <- lm(Umsatz ~ KielerWoche + Donnerstag + Freitag + Montag + Samstag + Sonntag + Dezember + Februar + Januar + Mai + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Herbst + Sommer, data = df_lm_train_WG1_28)
library(broom)
glance(lm_WG1_28_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.547 0.538 26.9 60.0 3.51e-216 29 -6674. 13408.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 31.0716942 0.5700155 23.3668499
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt prog_MLP_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
# Hinzufügen der Ergebnisse
df_lm_test_WG1_28 <- df_lm_test_WG1_28 %>%
mutate(predicted = lm_WG1_28_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_28 <- df_lm_test_WG1_28 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_28 <-df_lm_test_WG1_28 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_28 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best28_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- temp
lm_vgl_kennz## # A tibble: 1 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## # ... with 1 more variable: Modell <chr>
36-Variablen-Modell
Dieses Modell wird nun verglichen mit dem 36-Variablen-Modell:
## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.549 0.537 26.9 45.4 1.88e-209 38 -6672. 13421.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 30.8056218 0.5781609 23.1506032
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt prog_MLP_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
df_lm_test_WG1_36 <- df_lm_test_WG1
# Hinzufügen der Ergebnisse
df_lm_test_WG1_36 <- df_lm_test_WG1_36 %>%
mutate(predicted = lm_WG1_36_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_36 <- df_lm_test_WG1_36 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_36 <-df_lm_test_WG1_36 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_36 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best36_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 2 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## # ... with 1 more variable: Modell <chr>
6.3.2 Warengruppe 2
Erstellung von Trainings- und Testdatensätzen für Warengruppe 2
df_lm_train_WG2 <- df_lm_train %>% filter(Warengruppe == "2")
df_lm_train_WG2 <- na.omit(df_lm_train_WG2)
df_lm_train_WG2 <- df_lm_train_WG2 %>% dplyr::select(-Warengruppe)
df_lm_test_WG2 <- df_lm_test %>% filter(Warengruppe == "2")
df_lm_test_WG2 <- na.omit(df_lm_test_WG2)
df_lm_test_WG2 <- df_lm_test_WG2 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”) vgl. Abschnitt
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG2, nvmax = 36)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 36
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " "*" " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " " " "*" " "
## 7 ( 1 ) "*" " " "*" " "
## 8 ( 1 ) "*" " " "*" " "
## 9 ( 1 ) "*" " " "*" " "
## 10 ( 1 ) "*" " " "*" " "
## 11 ( 1 ) "*" " " "*" " "
## 12 ( 1 ) "*" " " "*" " "
## 13 ( 1 ) "*" " " "*" " "
## 14 ( 1 ) "*" " " "*" " "
## 15 ( 1 ) "*" " " "*" " "
## 16 ( 1 ) "*" " " "*" " "
## 17 ( 1 ) "*" " " "*" " "
## 18 ( 1 ) "*" " " "*" " "
## 19 ( 1 ) "*" " " "*" " "
## 20 ( 1 ) "*" "*" "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) " " " " " "
## 17 ( 1 ) " " "*" " "
## 18 ( 1 ) " " "*" " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) " " "*" " "
## 23 ( 1 ) " " "*" " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) " " "*" " "
## 26 ( 1 ) " " "*" " "
## 27 ( 1 ) " " "*" "*"
## 28 ( 1 ) " " "*" "*"
## 29 ( 1 ) " " "*" "*"
## 30 ( 1 ) " " "*" "*"
## 31 ( 1 ) " " "*" "*"
## 32 ( 1 ) " " "*" "*"
## 33 ( 1 ) " " "*" "*"
## 34 ( 1 ) "*" "*" " "
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " "*" "*"
## 4 ( 1 ) " " "*" "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) " " "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) " " "*" "*"
## 20 ( 1 ) " " "*" "*"
## 21 ( 1 ) " " "*" "*"
## 22 ( 1 ) " " "*" "*"
## 23 ( 1 ) " " "*" "*"
## 24 ( 1 ) " " "*" "*"
## 25 ( 1 ) " " "*" "*"
## 26 ( 1 ) " " "*" "*"
## 27 ( 1 ) " " "*" "*"
## 28 ( 1 ) " " "*" "*"
## 29 ( 1 ) " " "*" "*"
## 30 ( 1 ) " " "*" "*"
## 31 ( 1 ) " " "*" "*"
## 32 ( 1 ) " " "*" "*"
## 33 ( 1 ) " " "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " "*"
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" "*"
## 23 ( 1 ) " " " " "*" "*"
## 24 ( 1 ) " " " " "*" "*"
## 25 ( 1 ) "*" " " "*" "*"
## 26 ( 1 ) "*" " " "*" "*"
## 27 ( 1 ) "*" " " "*" "*"
## 28 ( 1 ) "*" " " "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" " " "*"
## 31 ( 1 ) "*" "*" " " "*"
## 32 ( 1 ) "*" "*" " " "*"
## 33 ( 1 ) "*" "*" " " "*"
## 34 ( 1 ) "*" "*" " " "*"
## 35 ( 1 ) "*" "*" " " "*"
## 36 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " " "
## 13 ( 1 ) " " " " " " " " " "
## 14 ( 1 ) " " " " " " " " " "
## 15 ( 1 ) " " " " " " " " " "
## 16 ( 1 ) " " " " " " "*" " "
## 17 ( 1 ) " " " " " " "*" " "
## 18 ( 1 ) " " " " " " "*" " "
## 19 ( 1 ) " " " " " " "*" " "
## 20 ( 1 ) " " " " " " "*" " "
## 21 ( 1 ) " " " " " " "*" " "
## 22 ( 1 ) " " "*" " " "*" " "
## 23 ( 1 ) " " "*" " " "*" " "
## 24 ( 1 ) " " "*" " " "*" " "
## 25 ( 1 ) "*" "*" " " "*" " "
## 26 ( 1 ) "*" "*" " " "*" " "
## 27 ( 1 ) "*" "*" " " "*" " "
## 28 ( 1 ) "*" "*" " " "*" " "
## 29 ( 1 ) "*" "*" " " "*" "*"
## 30 ( 1 ) "*" "*" " " "*" "*"
## 31 ( 1 ) "*" "*" " " "*" "*"
## 32 ( 1 ) "*" "*" " " "*" "*"
## 33 ( 1 ) "*" "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " " " "*"
## 10 ( 1 ) "*" " " " " "*"
## 11 ( 1 ) "*" " " " " "*"
## 12 ( 1 ) "*" " " " " "*"
## 13 ( 1 ) "*" " " "*" "*"
## 14 ( 1 ) "*" " " "*" "*"
## 15 ( 1 ) "*" " " "*" "*"
## 16 ( 1 ) "*" " " "*" "*"
## 17 ( 1 ) "*" " " "*" "*"
## 18 ( 1 ) "*" " " "*" "*"
## 19 ( 1 ) "*" " " "*" "*"
## 20 ( 1 ) "*" " " "*" "*"
## 21 ( 1 ) "*" " " "*" "*"
## 22 ( 1 ) "*" " " "*" "*"
## 23 ( 1 ) "*" " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " "*" "*" " "
## 7 ( 1 ) " " "*" "*" " "
## 8 ( 1 ) " " "*" "*" " "
## 9 ( 1 ) " " "*" "*" " "
## 10 ( 1 ) " " "*" "*" " "
## 11 ( 1 ) " " "*" "*" " "
## 12 ( 1 ) " " "*" "*" " "
## 13 ( 1 ) " " "*" "*" " "
## 14 ( 1 ) " " "*" "*" " "
## 15 ( 1 ) "*" "*" "*" " "
## 16 ( 1 ) "*" "*" "*" " "
## 17 ( 1 ) "*" "*" "*" " "
## 18 ( 1 ) "*" "*" "*" " "
## 19 ( 1 ) "*" "*" "*" " "
## 20 ( 1 ) "*" "*" "*" " "
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" " " " "
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" " " " "
## 32 ( 1 ) "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" " "
## 35 ( 1 ) "*" "*" "*" " "
## 36 ( 1 ) "*" "*" "*" " "
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " " " "*"
## 10 ( 1 ) " " " " " " "*"
## 11 ( 1 ) " " " " " " "*"
## 12 ( 1 ) " " " " " " "*"
## 13 ( 1 ) " " " " " " "*"
## 14 ( 1 ) " " " " " " "*"
## 15 ( 1 ) " " " " " " "*"
## 16 ( 1 ) " " " " " " "*"
## 17 ( 1 ) " " " " " " "*"
## 18 ( 1 ) " " " " " " "*"
## 19 ( 1 ) " " " " " " "*"
## 20 ( 1 ) " " " " " " "*"
## 21 ( 1 ) " " " " " " "*"
## 22 ( 1 ) " " " " " " "*"
## 23 ( 1 ) " " " " " " "*"
## 24 ( 1 ) " " " " " " "*"
## 25 ( 1 ) " " " " " " "*"
## 26 ( 1 ) " " " " " " "*"
## 27 ( 1 ) " " " " " " "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) " " " " " " "*"
## 30 ( 1 ) " " " " " " "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " "*"
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) "*" " " "*"
## 13 ( 1 ) "*" " " "*"
## 14 ( 1 ) "*" "*" "*"
## 15 ( 1 ) "*" "*" "*"
## 16 ( 1 ) "*" "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) "*" "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) "*" "*" "*"
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) "*" " " " "
## 11 ( 1 ) "*" " " " "
## 12 ( 1 ) "*" " " " "
## 13 ( 1 ) "*" " " " "
## 14 ( 1 ) "*" " " " "
## 15 ( 1 ) "*" " " " "
## 16 ( 1 ) "*" " " " "
## 17 ( 1 ) "*" " " " "
## 18 ( 1 ) "*" " " " "
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" " " " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" " "
## 25 ( 1 ) "*" " " " "
## 26 ( 1 ) "*" " " " "
## 27 ( 1 ) "*" " " " "
## 28 ( 1 ) "*" " " " "
## 29 ( 1 ) "*" " " " "
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die erzeugte Dummy-Variable Temperatur ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Wochentag das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Temperatur + Wochentag_cSonntag. Das beste 3-Variablen-Modell ist Umsatz ~ Temperatur + Wochentag_cSonntag + Wochentag_cSamstag. Und so weiter.
Schrittweise Auswahl (“Stepwise selection”)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_p\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG2)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:36,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 32
## [1] 19
## [1] 27
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass das 29-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt das 21-Variablenmodell vor und der \(C_p\) das 28-Variablen-Modell vor.
Die Variablen und Koeffizienten, die diese Modelle enthalten, können mittels der coef-Funktion verglichen werden:
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG2, nvmax = 36, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG2, nvmax = 36, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 31
## [1] 30
Wenn man das optimale \(C_p\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 31-Variablen-Modell die \(C_p\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 30-Variablen-Modell vor.
Wenn wir diese Modelle bewerten, ergibt sich bzgl. der Zusammensetzung der Prädikatoren-Stes folgendes Bild:.
## (Intercept) KielerWoche Temperatur
## 289.670164 114.755085 3.600748
## Wochentag_cFreitag Wochentag_cSamstag Wochentag_cSonntag
## 16.387490 116.592843 173.747069
## Monat_cFebruar Monat_cJanuar Monat_cMärz
## -22.100382 -32.805725 -34.469215
## Monat_cOktober SommerferienSH SommerferienNRW
## 73.884630 53.595044 91.667246
## SommerferienNDS SommerferienHE Feiertag
## 35.696146 52.963997 85.242085
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 190.112727 88.877808 82.507410
## Silvester_ext JahreszeitHerbst
## 161.447644 -45.983222
## (Intercept) KielerWoche Bewoelkung
## 300.4426300 106.4081526 -1.9944071
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.2458640 0.6731218 14.7321877
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.3828287 114.3262895 172.0672918
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 31.1385438 -21.1880439 -33.8672705
## Monat_cJuli Monat_cJuni Monat_cMärz
## 31.2779417 27.9457291 -31.2614621
## Monat_cOktober Monat_cSeptember SommerferienSH
## 82.4987784 23.9082216 50.1380316
## SommerferienNRW SommerferienNDS SommerferienHE
## 85.2740232 30.9085069 51.9845646
## Feiertag Ostern Ostern_ext
## 101.1324749 -74.4678250 222.6716868
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 95.2641385 73.8723795 157.9220733
## JahreszeitHerbst
## -43.1588521
## (Intercept) KielerWoche Bewoelkung
## 293.0827010 117.9578507 -1.9346214
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.4993246 0.6804694 14.6799796
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.1008732 114.3486987 172.0861877
## Monat_cAugust Monat_cDezember Monat_cJanuar
## 51.7469927 33.5152883 -13.5854712
## Monat_cJuli Monat_cJuni Monat_cMärz
## 50.2015847 32.5389107 -17.6541448
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 37.2779931 114.7756775 48.0435134
## SommerferienSH SommerferienNRW SommerferienNDS
## 49.4695160 86.7619540 34.0360619
## SommerferienHE Feiertag ChristiHimmelfahrt
## 49.5138317 28.5135372 85.9076430
## Pfingsten TDE Ostern_ext
## 79.6428657 88.6400121 223.5391977
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 95.3051638 70.9997316 180.2951038
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## -72.2568178 -18.7856521 -13.9938689
## (Intercept) KielerWoche Bewoelkung
## 292.765074 114.260852 -2.015801
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.327146 0.673390 14.801048
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.329412 114.218439 171.927158
## Monat_cAugust Monat_cDezember Monat_cFebruar
## 50.019613 24.969686 -13.748135
## Monat_cJanuar Monat_cJuli Monat_cJuni
## -26.236367 49.120786 35.950175
## Monat_cMai Monat_cMärz Monat_cNovember
## 7.729174 -24.253729 30.173179
## Monat_cOktober Monat_cSeptember SommerferienSH
## 109.090498 45.033733 49.753894
## SommerferienNRW SommerferienNDS SommerferienHE
## 86.322642 33.050139 50.300003
## Feiertag Ostern Ostern_ext
## 101.087580 -75.156591 228.703658
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 93.973494 72.549792 140.420486
## JahreszeitHerbst JahreszeitSommer
## -62.975529 -12.896948
## (Intercept) KielerWoche Bewoelkung
## 291.1000866 117.9055938 -1.8890962
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.5185703 0.6569262 16.4305003
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 115.8533768 174.2325499 51.3109994
## Monat_cDezember Monat_cJanuar Monat_cJuli
## 33.5326738 -13.4151407 49.6403076
## Monat_cJuni Monat_cMärz Monat_cNovember
## 32.4225440 -17.4933789 37.2659441
## Monat_cOktober Monat_cSeptember SommerferienSH
## 114.6604583 47.9379579 49.4453514
## SommerferienNRW SommerferienNDS SommerferienHE
## 87.1796710 34.1141032 49.4758872
## ChristiHimmelfahrt Pfingsten TDE
## 117.5452725 107.8945339 118.1724318
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 239.6808168 94.0255530 72.0089146
## Silvester_ext JahreszeitHerbst JahreszeitSommer
## 193.7338412 -72.2121158 -18.7581004
## JahreszeitWinter
## -13.9848360
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 36)
for(i in 1:36) {
coef_x <- coef(best_subset_WG2, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG2$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 10309.836
## [2,] 8312.558
## [3,] 6592.104
## [4,] 5257.919
## [5,] 4747.595
## [6,] 4326.941
## [7,] 4056.363
## [8,] 3973.651
## [9,] 3855.485
## [10,] 3904.029
## [11,] 3774.393
## [12,] 3658.855
## [13,] 3398.222
## [14,] 3345.696
## [15,] 3301.675
## [16,] 3348.038
## [17,] 3309.606
## [18,] 3269.346
## [19,] 3196.513
## [20,] 3295.153
## [21,] 3266.798
## [22,] 3281.881
## [23,] 3256.237
## [24,] 3248.713
## [25,] 3190.708
## [26,] 3184.737
## [27,] 3173.610
## [28,] 3248.039
## [29,] 3123.081
## [30,] 3099.673
## [31,] 3175.625
## [32,] 3154.416
## [33,] 3136.870
## [34,] 3133.011
## [35,] 3130.445
## [36,] 3129.577
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA,36)
# Iterationen über jede Größe i
for(i in 1:36){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG2, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG2$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass das 30-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 29- sowie 36-Variablen-Modell scheinen vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 30-Variablen-Modell zu erhalten. Dieses Modell wird mit dem 19-und dem 29-Variablen-Modell verglichen.
Teilmengenauswahl für das 30-Variablen-Modell
final_best_WG2_30 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG2, nvmax = 36)
coef(final_best_WG2_30, 30)## (Intercept) KielerWoche Bewoelkung
## 293.547985 118.085019 -1.950524
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.488547 0.665880 14.757750
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.275431 114.135925 171.819049
## Monat_cAugust Monat_cDezember Monat_cJanuar
## 51.877147 33.538279 -13.615677
## Monat_cJuli Monat_cJuni Monat_cMärz
## 50.333570 32.531345 -17.647320
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 37.310589 115.402083 48.122208
## SommerferienSH SommerferienNRW SommerferienNDS
## 49.458657 86.762657 34.066516
## SommerferienHE Feiertag Ostern
## 49.460584 101.094265 -75.915539
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 225.344716 98.028610 74.589843
## Silvester_ext JahreszeitHerbst JahreszeitSommer
## 144.029191 -72.358801 -18.831174
## JahreszeitWinter
## -14.068113
Die 30 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cJanuar
- Monat_cJuli
- Monat_cJuni
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_30 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_30 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 30-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG2_30_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Windgeschwindigkeit + Freitag + Mittwoch + Samstag + Sonntag + August + Dezember + Januar + Juli + Juni + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + Ostern_ext + ChristiHimmelfahrt_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG2_30)
glance(lm_WG2_30_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.776 0.771 64.2 166. 0 30 -7910. 15881.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 56.2258855 0.8475938 45.2566413
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_30 <- df_lm_test_WG2_30 %>%
mutate(predicted = lm_WG2_30_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_30 <- df_lm_test_WG2_30 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_30 <-df_lm_test_WG2_30 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_30 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best30_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 3 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 29-Variablen-Modell
final_best_WG2_29 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG2, nvmax = 36)
coef(final_best_WG2_29, 29)## (Intercept) KielerWoche Bewoelkung
## 294.6935059 106.5571748 -1.9875605
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.4480401 0.6757591 14.8360286
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.3650515 114.3795555 172.0025280
## Monat_cAugust Monat_cDezember Monat_cFebruar
## 33.8656965 16.7438107 -16.4454150
## Monat_cJanuar Monat_cJuli Monat_cJuni
## -28.6803937 33.4206257 29.7671350
## Monat_cMärz Monat_cNovember Monat_cOktober
## -27.2694765 19.9690671 98.2589764
## Monat_cSeptember SommerferienSH SommerferienNRW
## 29.6820946 49.4735607 85.1950405
## SommerferienNDS SommerferienHE Feiertag
## 30.6063174 51.6387981 101.0754763
## Ostern Ostern_ext ChristiHimmelfahrt_ext
## -74.7726912 225.8105656 97.5796679
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 75.4327216 145.8808435 -55.8155927
Die 29 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuli
- Monat_cJuni
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
Es fehlen: Sommer, Winter; es kommt hinzu Februar (= -2+1 ==> 29)
Die Variablen Wochentag_c, Monat und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_29 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_29 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 29-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG2_29_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Windgeschwindigkeit + Freitag + Mittwoch + Samstag + Sonntag + August + Dezember + Januar + Februar + Juli + Juni + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + Ostern_ext + ChristiHimmelfahrt_ext + Silvester_ext + Herbst, data = df_lm_train_WG2_29)
glance(lm_WG2_29_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.776 0.771 64.2 172. 0 29 -7911. 15881.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 56.4723843 0.8458877 45.4639878
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(predicted = lm_WG2_29_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_29 <-df_lm_test_WG2_29 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_29 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best29_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 4 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## 4 346 130413 377 45 9 13 12 3189 56
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 19-Variablen-Modell
final_best_WG2_19 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG2, nvmax = 36)
coef(final_best_WG2_19, 19)## (Intercept) KielerWoche Temperatur
## 289.670164 114.755085 3.600748
## Wochentag_cFreitag Wochentag_cSamstag Wochentag_cSonntag
## 16.387490 116.592843 173.747069
## Monat_cFebruar Monat_cJanuar Monat_cMärz
## -22.100382 -32.805725 -34.469215
## Monat_cOktober SommerferienSH SommerferienNRW
## 73.884630 53.595044 91.667246
## SommerferienNDS SommerferienHE Feiertag
## 35.696146 52.963997 85.242085
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 190.112727 88.877808 82.507410
## Silvester_ext JahreszeitHerbst
## 161.447644 -45.983222
Die 19 Variablen sind die folgenden:
- KielerWoche
- Temperatur
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cOktober
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_19 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_19 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)- KielerWoche
- Temperatur
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cOktober
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
Für das 19-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG2_19_train <- lm(Umsatz ~ KielerWoche + Temperatur + Freitag + Samstag + Sonntag + Januar + Februar + Maerz + Oktober + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst, data = df_lm_train_WG2_29)
glance(lm_WG2_19_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.773 0.770 64.4 251. 0 20 -7919. 15879.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 56.5377124 0.8443661 44.6378509
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_19 <- df_lm_test_WG2_19 %>%
mutate(predicted = lm_WG2_19_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_19 <- df_lm_test_WG2_19 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_19 <-df_lm_test_WG2_19 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_19 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best19_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 5 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## 4 346 130413 377 45 9 13 12 3189 56
## 5 346 130413 377 45 9 13 12 3197 57
## # ... with 1 more variable: Modell <chr>
6.3.3 Warengruppe 5
Erstellung von Trainings- und Testdatensätzen für Warengruppe 5
df_lm_train_WG5 <- df_lm_train %>% filter(Warengruppe == "5")
df_lm_train_WG5 <- na.omit(df_lm_train_WG5)
df_lm_train_WG5 <- df_lm_train_WG5 %>% dplyr::select(-Warengruppe)
df_lm_test_WG5 <- df_lm_test %>% filter(Warengruppe == "5")
df_lm_test_WG5 <- na.omit(df_lm_test_WG5)
df_lm_test_WG5 <- df_lm_test_WG5 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”) vgl. Abschnitt
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG5, nvmax = 36)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 36
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " " " " "
## 20 ( 1 ) " " " " " " " "
## 21 ( 1 ) " " "*" "*" " "
## 22 ( 1 ) " " " " "*" " "
## 23 ( 1 ) " " "*" "*" " "
## 24 ( 1 ) " " "*" "*" " "
## 25 ( 1 ) " " "*" "*" " "
## 26 ( 1 ) " " "*" "*" " "
## 27 ( 1 ) "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" " "
## 30 ( 1 ) "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " "*" " "
## 15 ( 1 ) " " "*" " "
## 16 ( 1 ) " " "*" " "
## 17 ( 1 ) " " "*" " "
## 18 ( 1 ) " " "*" " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) " " "*" " "
## 23 ( 1 ) " " "*" " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) " " "*" " "
## 26 ( 1 ) " " "*" " "
## 27 ( 1 ) " " "*" " "
## 28 ( 1 ) " " "*" " "
## 29 ( 1 ) " " "*" " "
## 30 ( 1 ) " " "*" " "
## 31 ( 1 ) " " "*" " "
## 32 ( 1 ) " " "*" " "
## 33 ( 1 ) " " "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " "*" " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " "*" " "
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) " " "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) " " "*" "*"
## 21 ( 1 ) " " "*" "*"
## 22 ( 1 ) " " "*" "*"
## 23 ( 1 ) " " "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " "*" " " " "
## 11 ( 1 ) " " "*" " " " "
## 12 ( 1 ) " " "*" " " " "
## 13 ( 1 ) "*" "*" " " " "
## 14 ( 1 ) "*" "*" " " " "
## 15 ( 1 ) "*" "*" "*" " "
## 16 ( 1 ) "*" "*" "*" " "
## 17 ( 1 ) " " "*" "*" " "
## 18 ( 1 ) " " "*" "*" " "
## 19 ( 1 ) " " "*" "*" " "
## 20 ( 1 ) " " "*" "*" " "
## 21 ( 1 ) " " "*" " " "*"
## 22 ( 1 ) " " "*" "*" " "
## 23 ( 1 ) " " "*" "*" " "
## 24 ( 1 ) " " "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" " "
## 27 ( 1 ) "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" " "
## 30 ( 1 ) "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" " "
## 32 ( 1 ) "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" " "
## 35 ( 1 ) "*" "*" "*" " "
## 36 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " "*"
## 13 ( 1 ) " " " " " " " " "*"
## 14 ( 1 ) " " " " " " " " "*"
## 15 ( 1 ) " " " " " " " " "*"
## 16 ( 1 ) " " " " " " " " "*"
## 17 ( 1 ) "*" " " " " " " "*"
## 18 ( 1 ) "*" " " " " " " "*"
## 19 ( 1 ) "*" " " " " " " "*"
## 20 ( 1 ) "*" "*" "*" " " "*"
## 21 ( 1 ) "*" "*" " " "*" "*"
## 22 ( 1 ) " " "*" "*" " " " "
## 23 ( 1 ) " " "*" "*" " " " "
## 24 ( 1 ) " " "*" "*" " " " "
## 25 ( 1 ) " " "*" "*" " " " "
## 26 ( 1 ) " " "*" "*" " " " "
## 27 ( 1 ) "*" "*" "*" " " " "
## 28 ( 1 ) "*" "*" "*" " " " "
## 29 ( 1 ) " " "*" "*" " " " "
## 30 ( 1 ) "*" "*" "*" " " " "
## 31 ( 1 ) "*" "*" "*" " " " "
## 32 ( 1 ) "*" "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" "*" " "
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " "*" " "
## 18 ( 1 ) " " " " "*" " "
## 19 ( 1 ) " " " " "*" " "
## 20 ( 1 ) "*" " " "*" " "
## 21 ( 1 ) " " " " "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" "*"
## 6 ( 1 ) " " " " "*" "*"
## 7 ( 1 ) " " " " "*" "*"
## 8 ( 1 ) " " " " "*" "*"
## 9 ( 1 ) " " " " "*" "*"
## 10 ( 1 ) " " " " "*" "*"
## 11 ( 1 ) " " " " "*" "*"
## 12 ( 1 ) " " " " "*" "*"
## 13 ( 1 ) " " " " "*" "*"
## 14 ( 1 ) " " " " "*" "*"
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) " " " " "*" "*"
## 18 ( 1 ) " " "*" "*" "*"
## 19 ( 1 ) " " "*" "*" "*"
## 20 ( 1 ) " " "*" "*" "*"
## 21 ( 1 ) " " "*" "*" "*"
## 22 ( 1 ) " " "*" "*" "*"
## 23 ( 1 ) " " "*" "*" "*"
## 24 ( 1 ) " " "*" "*" "*"
## 25 ( 1 ) " " "*" "*" "*"
## 26 ( 1 ) " " "*" "*" "*"
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) "*" "*" "*" " "
## 6 ( 1 ) "*" "*" "*" " "
## 7 ( 1 ) "*" "*" "*" " "
## 8 ( 1 ) "*" "*" "*" " "
## 9 ( 1 ) "*" "*" "*" "*"
## 10 ( 1 ) "*" "*" "*" " "
## 11 ( 1 ) "*" "*" "*" "*"
## 12 ( 1 ) "*" "*" "*" "*"
## 13 ( 1 ) "*" "*" "*" "*"
## 14 ( 1 ) "*" "*" "*" "*"
## 15 ( 1 ) "*" "*" "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " "*"
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " " " "*"
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " "*"
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) " " " " "*"
## 13 ( 1 ) " " " " "*"
## 14 ( 1 ) " " " " "*"
## 15 ( 1 ) " " " " "*"
## 16 ( 1 ) " " " " "*"
## 17 ( 1 ) " " " " "*"
## 18 ( 1 ) " " " " "*"
## 19 ( 1 ) " " " " "*"
## 20 ( 1 ) " " " " "*"
## 21 ( 1 ) " " " " "*"
## 22 ( 1 ) " " " " "*"
## 23 ( 1 ) " " " " "*"
## 24 ( 1 ) " " " " "*"
## 25 ( 1 ) " " " " "*"
## 26 ( 1 ) " " " " "*"
## 27 ( 1 ) " " " " "*"
## 28 ( 1 ) " " " " "*"
## 29 ( 1 ) " " "*" "*"
## 30 ( 1 ) " " "*" "*"
## 31 ( 1 ) " " "*" "*"
## 32 ( 1 ) " " "*" "*"
## 33 ( 1 ) " " "*" "*"
## 34 ( 1 ) " " "*" "*"
## 35 ( 1 ) " " "*" "*"
## 36 ( 1 ) " " "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " "*" " "
## 4 ( 1 ) " " "*" " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " "*" " "
## 7 ( 1 ) " " "*" " "
## 8 ( 1 ) " " "*" " "
## 9 ( 1 ) " " "*" " "
## 10 ( 1 ) " " "*" " "
## 11 ( 1 ) " " "*" " "
## 12 ( 1 ) " " "*" " "
## 13 ( 1 ) " " "*" " "
## 14 ( 1 ) " " "*" " "
## 15 ( 1 ) " " "*" " "
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) " " "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) " " "*" "*"
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die Variable Silvester_ext ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Silvester_ext das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Silvester_ext + Feiertag. Das beste 3-Variablen-Modell ist Umsatz ~ Silvester_ext + Feiertag + JahreszeitSommer. Und so weiter.
Schrittweise Auswahl (“Stepwise selection”)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_p\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG5)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:36,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 31
## [1] 23
## [1] 27
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass ein 31-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt ein 23-Variablenmodell vor und der \(C_p\) ein 27-Variablen-Modell vor.
Die Variablen und Koeffizienten, die diese Modelle enthalten, können mittels der coef-Funktion verglichen werden:
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG5, nvmax = 36, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG5, nvmax = 36, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 28
## [1] 26
Wenn man das optimale \(C_p\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 28-Variablen-Modell die \(C_p\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 26-Variablen-Modell vor.
Wenn wir diese Modelle bewerten, ergibt sich bzgl. der Zusammensetzung der Prädikatoren-Stes folgendes Bild:.
## (Intercept) KielerWoche Bewoelkung
## 301.250888 94.057770 -1.797666
## Temperatur Wochentag_cFreitag Wochentag_cSamstag
## 2.734308 16.662111 116.628698
## Wochentag_cSonntag Monat_cFebruar Monat_cJanuar
## 174.275923 -19.850592 -31.638704
## Monat_cJuni Monat_cMärz Monat_cOktober
## 20.493295 -30.924607 76.758787
## SommerferienSH SommerferienNRW SommerferienNDS
## 51.694084 89.140944 30.641686
## SommerferienHE Feiertag Ostern
## 54.560830 102.718009 -78.007547
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 225.362002 91.871933 73.486780
## Silvester_ext JahreszeitHerbst JahreszeitSommer
## 157.120502 -40.761042 18.511756
## (Intercept) KielerWoche Bewoelkung
## 298.4058891 106.4001612 -1.9601782
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.2603774 0.6562782 16.6265420
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 116.2050194 173.9271810 30.7823571
## Monat_cFebruar Monat_cJanuar Monat_cJuli
## -21.0649132 -33.7019731 30.7734204
## Monat_cJuni Monat_cMärz Monat_cOktober
## 27.8575210 -31.1960221 82.4069891
## Monat_cSeptember SommerferienSH SommerferienNRW
## 23.8591045 50.0767350 85.7216200
## SommerferienNDS SommerferienHE Feiertag
## 31.0085289 51.9384915 102.2313522
## Ostern Ostern_ext ChristiHimmelfahrt_ext
## -75.4954444 223.6163126 94.3633522
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 74.2712983 156.5130094 -43.1068555
## (Intercept) KielerWoche Bewoelkung
## 300.4426300 106.4081526 -1.9944071
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.2458640 0.6731218 14.7321877
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.3828287 114.3262895 172.0672918
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 31.1385438 -21.1880439 -33.8672705
## Monat_cJuli Monat_cJuni Monat_cMärz
## 31.2779417 27.9457291 -31.2614621
## Monat_cOktober Monat_cSeptember SommerferienSH
## 82.4987784 23.9082216 50.1380316
## SommerferienNRW SommerferienNDS SommerferienHE
## 85.2740232 30.9085069 51.9845646
## Feiertag Ostern Ostern_ext
## 101.1324749 -74.4678250 222.6716868
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 95.2641385 73.8723795 157.9220733
## JahreszeitHerbst
## -43.1588521
## (Intercept) KielerWoche Bewoelkung
## 299.8776862 106.2921307 -1.9639509
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.2656223 0.6794816 14.5577923
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.2197744 114.2026602 172.6708574
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 31.0020793 -21.0191703 -33.6638528
## Monat_cJuli Monat_cJuni Monat_cMärz
## 31.1509408 27.9426583 -31.0538129
## Monat_cOktober Monat_cSeptember SommerferienSH
## 81.8368548 23.8411205 50.1837918
## SommerferienNRW SommerferienNDS SommerferienHE
## 85.2628970 30.8781814 52.0329144
## ChristiHimmelfahrt Pfingsten TDE
## 113.6871502 107.6889886 117.9701401
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 236.8914773 92.7344715 70.5223734
## Silvester_ext JahreszeitHerbst
## 208.6224408 -43.0396032
## (Intercept) KielerWoche Bewoelkung
## 293.0113864 117.9568840 -1.9211801
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 2.5069296 0.6727934 14.5933059
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -7.1085068 114.0389427 172.4127971
## Monat_cAugust Monat_cDezember Monat_cJanuar
## 51.7213242 33.5731131 -13.5143658
## Monat_cJuli Monat_cJuni Monat_cMärz
## 50.1873647 32.5206859 -17.5128608
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 37.3224676 114.7856739 48.0454212
## SommerferienSH SommerferienNRW SommerferienNDS
## 49.5018200 86.7519574 34.0314310
## SommerferienHE ChristiHimmelfahrt Pfingsten
## 49.5111317 114.4060608 107.8570538
## TDE Ostern_ext ChristiHimmelfahrt_ext
## 117.2474784 238.7638569 95.3318619
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 71.1288325 194.5744842 -72.2772230
## JahreszeitSommer JahreszeitWinter
## -18.8157120 -13.9950373
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 36)
for(i in 1:36) {
coef_x <- coef(best_subset_WG5, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG5$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 5961.308
## [2,] 5625.944
## [3,] 4793.030
## [4,] 4611.951
## [5,] 3674.561
## [6,] 2912.423
## [7,] 2756.433
## [8,] 2583.962
## [9,] 2643.741
## [10,] 2569.861
## [11,] 2629.672
## [12,] 2617.751
## [13,] 2626.376
## [14,] 2598.037
## [15,] 2582.050
## [16,] 2537.701
## [17,] 2624.419
## [18,] 2636.687
## [19,] 2652.674
## [20,] 2582.490
## [21,] 2624.994
## [22,] 2690.118
## [23,] 2718.861
## [24,] 2735.742
## [25,] 2596.415
## [26,] 2572.770
## [27,] 2552.562
## [28,] 2541.491
## [29,] 2578.557
## [30,] 2561.362
## [31,] 2557.819
## [32,] 2570.796
## [33,] 2572.098
## [34,] 2566.724
## [35,] 2562.191
## [36,] 2563.196
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA,36)
# Iterationen über jede Größe i
for(i in 1:36){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG5, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG5$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass das 16-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 27/28- sowie 10-Variablen-Modell scheinen vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 16-Variablen-Modell zu erhalten. Dieses Modell wird mit dem 10-und dem 28-Variablen-Modell verglichen.
Teilmengenauswahl für das 16-Variablen-Modell
final_best_WG5_16 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG5, nvmax = 36)
coef(final_best_WG5_16, 16)## (Intercept) Wochentag_cFreitag Wochentag_cSamstag
## 249.72536 16.66969 51.68771
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## 48.26968 34.83759 -46.80853
## Monat_cFebruar Monat_cNovember Feiertag
## 28.33683 -33.11208 1300.37500
## Ostern ChristiHimmelfahrt Pfingsten
## -1416.90490 -1216.92786 -1227.69895
## TDE Ostern_ext Silvester_ext
## -1236.63221 142.41595 207.73776
## JahreszeitSommer JahreszeitWinter
## 27.08401 -14.27894
Die 16 Variablen sind die folgenden:
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cNovember
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Silvester_ext
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_16 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_16 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 16-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG5_16_train <- lm(Umsatz ~ Freitag + Samstag + Sonntag + August + Dezember + Februar + November + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Sommer + Winter, data = df_lm_train_WG5_16)
glance(lm_WG5_16_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.771 0.768 47.2 295. 0 17 -7478. 14993.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 50.3755948 0.7299486 37.6690892
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_16 <- df_lm_test_WG5_16 %>%
mutate(predicted = lm_WG5_16_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_16 <-df_lm_test_WG5_16 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_16 <- df_lm_test_WG5_16 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_16 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best16_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 6 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## 4 346 130413 377 45 9 13 12 3189 56
## 5 346 130413 377 45 9 13 12 3197 57
## 6 346 93912 271 38 4 15 14 2538 50
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 10-Variablen-Modell
final_best_WG5_10 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG5, nvmax = 36)
coef(final_best_WG5_10, 10)## (Intercept) Wochentag_cSamstag Wochentag_cSonntag
## 248.52590 50.84156 44.15509
## Monat_cDezember Feiertag Ostern
## -46.09735 1297.23623 -1268.09343
## ChristiHimmelfahrt Pfingsten TDE
## -1212.58963 -1221.30343 -1227.91502
## Silvester_ext JahreszeitSommer
## 198.32605 42.79698
Die 10 Variablen sind die folgenden:
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Silvester_ext
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_10 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_10 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 10-Variablenmodell wird nun ein Regressionsmodell erstellt:
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Silvester_ext
- JahreszeitSommer
lm_WG5_10_train <- lm(Umsatz ~ Samstag + Sonntag + Dezember + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Silvester_ext + Sommer, data = df_lm_train_WG5_16)
glance(lm_WG5_16_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.771 0.768 47.2 295. 0 17 -7478. 14993.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 50.6938004 0.7254496 38.9986394
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_10 <- df_lm_test_WG5_10 %>%
mutate(predicted = lm_WG5_10_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_10 <-df_lm_test_WG5_10 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_10 <- df_lm_test_WG5_10 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_10 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best10_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 7 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## 4 346 130413 377 45 9 13 12 3189 56
## 5 346 130413 377 45 9 13 12 3197 57
## 6 346 93912 271 38 4 15 14 2538 50
## 7 346 93912 271 39 4 15 14 2570 51
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 28-Variablen-Modell
final_best_WG5_28 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG5, nvmax = 36)
coef(final_best_WG5_28, 28)## (Intercept) KielerWoche Bewoelkung
## 270.582678 17.588695 -1.679758
## Temperatur Wochentag_cFreitag Wochentag_cMontag
## -1.855428 14.444043 -10.009566
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 49.272882 46.327127 33.755567
## Monat_cDezember Monat_cFebruar Monat_cJuli
## -22.226035 31.576312 14.523265
## Monat_cJuni Monat_cMai Monat_cOktober
## 30.706013 22.246078 48.138558
## Monat_cSeptember SommerferienSH SommerferienNRW
## 36.228830 21.973377 8.385879
## SommerferienHE Feiertag Ostern
## 18.801835 1303.646468 -1414.870428
## ChristiHimmelfahrt Pfingsten TDE
## -1230.986189 -1236.107382 -1240.001303
## Ostern_ext Silvester_ext JahreszeitHerbst
## 147.016249 185.737014 -28.827390
## JahreszeitSommer JahreszeitWinter
## 12.932174 -18.124977
Die 28 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_28 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_28 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 28-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG5_28_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Freitag + Montag + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG5_16)
glance(lm_WG5_28_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.783 0.779 46.1 179. 0 29 -7439. 14939.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 50.4132033 0.7296061 37.6349030
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_28 <- df_lm_test_WG5_28 %>%
mutate(predicted = lm_WG5_28_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_28 <-df_lm_test_WG5_28 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_28 <- df_lm_test_WG5_28 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_28 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best28_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 8 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 23 -4 18 18 965 31
## 2 346 45738 132 23 -4 18 18 949 31
## 3 346 130413 377 45 9 13 12 3161 56
## 4 346 130413 377 45 9 13 12 3189 56
## 5 346 130413 377 45 9 13 12 3197 57
## 6 346 93912 271 38 4 15 14 2538 50
## 7 346 93912 271 39 4 15 14 2570 51
## 8 346 93912 271 38 4 14 14 2541 50
## # ... with 1 more variable: Modell <chr>
7 Anwendung von ML Verfahren: Support Vector Machines (SVM)
7.1 Vorhaben
Wir testen nun ein anerkanntes Verfahren aus dem Bereich Machine Learning (ML), nämlich Support Vector Machines (SVM).
7.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_SVM auf Basis von df_voll. Redundante Spalten nehmen wir raus (Wochentag, Monat, Jahreszeit) und entfernen die nicht benötigten Umsatz-Spalten (Umsatz_NA sowie die Umsatz_lag Variablen).
df_SVM <- df_voll
# verwende nur originäre Umsatzdaten und grenze den Zeitraum auf 2015 bis 2018 ein
df_SVM <- df_SVM %>%
filter(Umsatz_NA == FALSE) %>%
filter(Jahr >= 2015 & Jahr <= 2018)
# behalte nur die Spalten, die wir für unsere SVM verwenden wollen
df_SVM <- df_SVM %>%
dplyr::select(-Wochentag, -Monat, -Jahreszeit, -Umsatz_NA, -Umsatz_lag_1W, -Umsatz_lag_2W, -Umsatz_lag_3W, -Umsatz_lag_4W, -Umsatz_lag)Wir eleminieren nun fehlende Werte, dummyfizieren Wochentag_c und Monat_c (wobei wir im Gegensatz zur linearen Regression alle Wochentage und alle Monate behalten) und skalieren die Variablen Temperatur, Bewoelkung und Windgeschwindigkeit auf Werte im Bereich zwischen 0 und 1. Danach werden die alten Variablen Wochentag_c und Monat_c entfernt.
# eliminiere fehlende Werte
df_SVM <- na.omit(df_SVM)
# dummyfiziere Wochentag_c und Monat_c
df_SVM <- df_SVM %>%
mutate(Montag=as.integer(df_SVM$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_SVM$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_SVM$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_SVM$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_SVM$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_SVM$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_SVM$Wochentag_c=="Sonntag")) %>%
dplyr::select(-Wochentag_c)
df_SVM <- df_SVM %>%
mutate(Januar=as.integer(df_SVM$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_SVM$Monat_c=="Februar")) %>%
mutate(März=as.integer(df_SVM$Monat_c=="März")) %>%
mutate(April=as.integer(df_SVM$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_SVM$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_SVM$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_SVM$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_SVM$Monat_c=="August")) %>%
mutate(September=as.integer(df_SVM$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_SVM$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_SVM$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_SVM$Monat_c=="Dezember")) %>%
dplyr::select(-Monat_c)
# skaliere die Variablen Temperatur, Bewoelkung und Windgeschwindigkeit auf [0,1].
# ermittle vorher die Spannweite der Variablenausprägungen
range(df_SVM$Umsatz) # 23..1870## [1] 23.11 1869.94
## [1] -6.1 32.7
## [1] 0 8
## [1] 3 35
df_SVM <- df_SVM %>%
# mutate(Umsatz = Umsatz / 2000) %>%
mutate(Temperatur = (Temperatur + 10) / 50) %>%
mutate(Bewoelkung = Bewoelkung / 10) %>%
mutate(Windgeschwindigkeit = Windgeschwindigkeit / 50)Für die Trainingsdaten verwenden wir den Zeitraum 2015 bis 2017 und für die Testdaten das Jahr 2018. Die Modellierung erfolgt je Warengruppe, daher teilen wir den Datensatz df_SVM auf.
df_SVM_train <- df_SVM %>% filter(Jahr < 2018)
df_SVM_test <- df_SVM %>% filter(Jahr == 2018)
df_SVM_train_WG1 <- df_SVM_train %>% filter(Warengruppe==1)
df_SVM_train_WG2 <- df_SVM_train %>% filter(Warengruppe==2)
df_SVM_train_WG3 <- df_SVM_train %>% filter(Warengruppe==3)
df_SVM_train_WG4 <- df_SVM_train %>% filter(Warengruppe==4)
df_SVM_train_WG5 <- df_SVM_train %>% filter(Warengruppe==5)
df_SVM_test_WG1 <- df_SVM_test %>% filter(Warengruppe==1)
df_SVM_test_WG2 <- df_SVM_test %>% filter(Warengruppe==2)
df_SVM_test_WG3 <- df_SVM_test %>% filter(Warengruppe==3)
df_SVM_test_WG4 <- df_SVM_test %>% filter(Warengruppe==4)
df_SVM_test_WG5 <- df_SVM_test %>% filter(Warengruppe==5)Wir müssen dann noch die Trainings- und Testdaten aufteilen: Für die Erstellung der Inputdaten eliminieren wir die ersten vier Spalten, also Datum, Umsatz, Warengruppe und Jahr. Und die Targetvariable ist stets der Umsatz. Zunächst arbeiten wir mit ALLEN Inputvariablen.
# Warengruppe 1
df_SVM_train_WG1_input <- df_SVM_train_WG1 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG2_input <- df_SVM_train_WG2 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG3_input <- df_SVM_train_WG3 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG4_input <- df_SVM_train_WG4 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG5_input <- df_SVM_train_WG5 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG1_target <- df_SVM_train_WG1$Umsatz
df_SVM_train_WG2_target <- df_SVM_train_WG2$Umsatz
df_SVM_train_WG3_target <- df_SVM_train_WG3$Umsatz
df_SVM_train_WG4_target <- df_SVM_train_WG4$Umsatz
df_SVM_train_WG5_target <- df_SVM_train_WG5$Umsatz
df_SVM_test_WG1_input <- df_SVM_test_WG1 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG2_input <- df_SVM_test_WG2 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG3_input <- df_SVM_test_WG3 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG4_input <- df_SVM_test_WG4 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG5_input <- df_SVM_test_WG5 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG1_target <- df_SVM_test_WG1$Umsatz
df_SVM_test_WG2_target <- df_SVM_test_WG2$Umsatz
df_SVM_test_WG3_target <- df_SVM_test_WG3$Umsatz
df_SVM_test_WG4_target <- df_SVM_test_WG4$Umsatz
df_SVM_test_WG5_target <- df_SVM_test_WG5$Umsatz7.3 Modelparameter
Wir wollen im folgenden eine Regression mithilfe von SVM durchführen und verwenden dafür einen radial basis kernel. Die einzelnen Schritte führen wir zunächst für Warengruppe 1 im Detail durch und anschließend für die übrigen Warengruppen.
Warengruppe 1
# Modellierung auf Basis der Trainings-Inputs
model_SVM_WG1 <- svm(df_SVM_train_WG1_input, df_SVM_train_WG1_target)
summary(model_SVM_WG1)##
## Call:
## svm.default(x = df_SVM_train_WG1_input, y = df_SVM_train_WG1_target)
##
##
## Parameters:
## SVM-Type: eps-regression
## SVM-Kernel: radial
## cost: 1
## gamma: 0.02380952
## epsilon: 0.1
##
##
## Number of Support Vectors: 926
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG1_pred <- predict(model_SVM_WG1, df_SVM_train_WG1_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG1_pred <- predict(model_SVM_WG1, df_SVM_test_WG1_input)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den prognostizierten Umsätzen (blaue Kreuze) für die Trainingsdaten:
plot(df_SVM_train_WG1_target, df_SVM_train_WG1_target, pch=16)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred, col = "blue", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den prognostizierten Umsätzen (blaue Kreuze) für die Testdaten:
plot(df_SVM_test_WG1_target, df_SVM_test_WG1_target, pch=16)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred, col = "blue", pch=4)Die Modellparameter sind vorbelegt mit epsilon=0.1 und Cost=1 (C). Gamma erhält als Startwert den Kehrwert der Anzahl der Inputparameter. Wir wollen nun epsilon und C optimieren, um die Modellergebnisse zu verbessern. Dafür verwenden wir eine Rasteranalyse und variieren beide Parameter (grid search). Anschließend verwenden wir das gefundene Optimum:
# Die Rastersuche nach dem Optimum dauert einige Minuten, daher auskommentiert.
# model_SVM_WG1_tuned_grid <- tune(svm, df_SVM_train_WG1_input, df_SVM_train_WG1_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# Verwende das beste Modell (auskommentiert)
# model_SVM_WG1_tuned <- model_SVM_WG1_tuned_grid$best.model
# summary(model_SVM_WG1_tuned)
# Zur Zeitersparnis verwende nur die gefundenen optimalen Parameter: cost = 4, epsilon = 0.5
model_SVM_WG1_tuned <- svm(df_SVM_train_WG1_input, df_SVM_train_WG1_target, cost=4, epsilon=0.5)Jetzt wenden wir das optimierte Modell nochmal auf die Trainings- und Testinputs an:
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG1_pred_tuned <- predict(model_SVM_WG1_tuned, df_SVM_train_WG1_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG1_pred_tuned <- predict(model_SVM_WG1_tuned, df_SVM_test_WG1_input)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den einfach prognostizierten Umsätzen (blaue Kreuze) und zusätzlich die Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Trainingsdaten:
plot(df_SVM_train_WG1_target, df_SVM_train_WG1_target, pch=16)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred, col = "blue", pch=4)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred_tuned, col = "red", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den einfach prognostizierten Umsätzen (blaue Kreuze) und zusätzlich die Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Testsdaten:
plot(df_SVM_test_WG1_target, df_SVM_test_WG1_target, pch=16)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred, col = "blue", pch=4)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred_tuned, col = "red", pch=4)übrige Warengruppen
Die Modellparameter sind vorbelegt mit epsilon=0.1 und Cost=1 (C). Gamma erhält als Startwert den Kehrwert der Anzahl der Inputparameter. Wir wollen nun epsilon und C optimieren. Dafür verwenden wir wieder eine Rasteranalyse und variieren beide Parameter (grid search). Anschließend verwenden wir das gefundene Optimum:
# Die Rastersuche nach dem Optimum dauert einige Minuten, daher auskommentiert.
# model_SVM_WG2_tuned_grid <- tune(svm, df_SVM_train_WG2_input, df_SVM_train_WG2_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG3_tuned_grid <- tune(svm, df_SVM_train_WG3_input, df_SVM_train_WG3_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG4_tuned_grid <- tune(svm, df_SVM_train_WG4_input, df_SVM_train_WG4_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG5_tuned_grid <- tune(svm, df_SVM_train_WG5_input, df_SVM_train_WG5_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# Verwende das beste Modell (auskommentiert)
# model_SVM_WG2_tuned <- model_SVM_WG2_tuned_grid$best.model
# model_SVM_WG3_tuned <- model_SVM_WG3_tuned_grid$best.model
# model_SVM_WG4_tuned <- model_SVM_WG4_tuned_grid$best.model
# model_SVM_WG5_tuned <- model_SVM_WG5_tuned_grid$best.model
# summary(model_SVM_WG2_tuned) # cost = 4, epsilon = 0.2
# summary(model_SVM_WG3_tuned) # cost = 4, epsilon = 0.4
# summary(model_SVM_WG4_tuned) # cost = 4, epsilon = 0.8
# summary(model_SVM_WG5_tuned) # cost = 16, epsilon = 0.2
# Zur Zeitersparnis verwende nur die gefundenen optimalen Parameter: cost = 4, epsilon = 0.5
model_SVM_WG2_tuned <- svm(df_SVM_train_WG2_input, df_SVM_train_WG2_target, cost=4, epsilon=0.2)
model_SVM_WG3_tuned <- svm(df_SVM_train_WG3_input, df_SVM_train_WG3_target, cost=4, epsilon=0.4)
model_SVM_WG4_tuned <- svm(df_SVM_train_WG4_input, df_SVM_train_WG4_target, cost=4, epsilon=0.8)
model_SVM_WG5_tuned <- svm(df_SVM_train_WG5_input, df_SVM_train_WG5_target, cost=16, epsilon=0.2)Jetzt wenden wir die optimierten Modelle auf die Trainings- und Testinputs an:
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG2_pred_tuned <- predict(model_SVM_WG2_tuned, df_SVM_train_WG2_input)
SVM_train_WG3_pred_tuned <- predict(model_SVM_WG3_tuned, df_SVM_train_WG3_input)
SVM_train_WG4_pred_tuned <- predict(model_SVM_WG4_tuned, df_SVM_train_WG4_input)
SVM_train_WG5_pred_tuned <- predict(model_SVM_WG5_tuned, df_SVM_train_WG5_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG2_pred_tuned <- predict(model_SVM_WG2_tuned, df_SVM_test_WG2_input)
SVM_test_WG3_pred_tuned <- predict(model_SVM_WG3_tuned, df_SVM_test_WG3_input)
SVM_test_WG4_pred_tuned <- predict(model_SVM_WG4_tuned, df_SVM_test_WG4_input)
SVM_test_WG5_pred_tuned <- predict(model_SVM_WG5_tuned, df_SVM_test_WG5_input)Zeige die echten Umsätze (schwarze Punkte) zusammen mit der Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Trainingsdaten:
plot(df_SVM_train_WG2_target, df_SVM_train_WG2_target, pch=16)
points(df_SVM_train_WG2_target, SVM_train_WG2_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG3_target, df_SVM_train_WG3_target, pch=16)
points(df_SVM_train_WG3_target, SVM_train_WG3_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG4_target, df_SVM_train_WG4_target, pch=16)
points(df_SVM_train_WG4_target, SVM_train_WG4_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG5_target, df_SVM_train_WG5_target, pch=16)
points(df_SVM_train_WG5_target, SVM_train_WG5_pred_tuned, col = "red", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit der Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Testsdaten:
plot(df_SVM_test_WG2_target, df_SVM_test_WG2_target, pch=16)
points(df_SVM_test_WG2_target, SVM_test_WG2_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG3_target, df_SVM_test_WG3_target, pch=16)
points(df_SVM_test_WG3_target, SVM_test_WG3_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG4_target, df_SVM_test_WG4_target, pch=16)
points(df_SVM_test_WG4_target, SVM_test_WG4_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG5_target, df_SVM_test_WG5_target, pch=16)
points(df_SVM_test_WG5_target, SVM_test_WG5_pred_tuned, col = "red", pch=4)7.4 Modellergebnisse
Zunächst wandeln wir die Umsatzschätzer in einen dataframe um und benennen die Spalte entsprechend:
SVM_test_WG1_pred_tuned <- as.data.frame(SVM_test_WG1_pred_tuned)
SVM_test_WG2_pred_tuned <- as.data.frame(SVM_test_WG2_pred_tuned)
SVM_test_WG3_pred_tuned <- as.data.frame(SVM_test_WG3_pred_tuned)
SVM_test_WG4_pred_tuned <- as.data.frame(SVM_test_WG4_pred_tuned)
SVM_test_WG5_pred_tuned <- as.data.frame(SVM_test_WG5_pred_tuned)
colnames(SVM_test_WG1_pred_tuned) <- "Umsatz_WG1"
colnames(SVM_test_WG2_pred_tuned) <- "Umsatz_WG2"
colnames(SVM_test_WG3_pred_tuned) <- "Umsatz_WG3"
colnames(SVM_test_WG4_pred_tuned) <- "Umsatz_WG4"
colnames(SVM_test_WG5_pred_tuned) <- "Umsatz_WG5"Dann fügen wir die Umsatzschätzer an die Testdaten an und erstellen eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_SVM_vgl_kennz:
# WG1
df_SVM_test_WG1 <- cbind(df_SVM_test_WG1, SVM_test_WG1_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG1 <- df_SVM_test_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG1 <- df_SVM_test_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- temp
# WG2
df_SVM_test_WG2 <- cbind(df_SVM_test_WG2, SVM_test_WG2_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG2 <- df_SVM_test_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG2 <- df_SVM_test_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG3
df_SVM_test_WG3 <- cbind(df_SVM_test_WG3, SVM_test_WG3_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG3 <- df_SVM_test_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG3 <- df_SVM_test_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG4
df_SVM_test_WG4 <- cbind(df_SVM_test_WG4, SVM_test_WG4_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG4 <- df_SVM_test_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG4 <- df_SVM_test_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG5
df_SVM_test_WG5 <- cbind(df_SVM_test_WG5, SVM_test_WG5_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG5 <- df_SVM_test_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG5 <- df_SVM_test_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
prog_SVM_vgl_kennz## # A tibble: 5 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 25 -6 19 19 1193 35
## 2 346 130413 377 42 2 12 11 3015 55
## 3 346 59316 171 32 -7 18 18 1762 42
## 4 345 28354 82 19 14 25 23 584 24
## 5 346 93912 271 43 0 16 16 3176 56
## # ... with 1 more variable: Modell <chr>
Nun wollen wir und noch die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_SVM_vgl_relAbw. Diese müssen wir dann noch pivotieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- df_SVM_test_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_SVM_vgl_relAbw)[2]="WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[3]="WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[4]="WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[5]="WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[6]="WG5"
# pivotieren
prog_SVM_vgl_relAbw <- prog_SVM_vgl_relAbw %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_SVM_vgl_relAbw %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich SVM Modell 1: Relative Abweichung") +
xlab("Modell_Warengruppe") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
7.4 Fazit SVM-Modell
Fehlt noch!
8 Anwendung von DL Verfahren: Multilayer Perceptron (MLP)
8.1 Vorhaben
Wir wollen in diesem Abschnitt ein Verfahren aus dem Bereich Deep Learning (DL) testen. Genauer gesagt wollen wir ein künstliches neuronales Netz (kNN) in Form eines einfach Multilayer Perceptrons aufbauen. Wir verwenden dafür ein Python-Skript (MLP.py).
8.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_MLP auf Basis von df_voll.
df_MLP <- df_voll
# verwende nur originäre Umsatzdaten und grenze den Zeitraum auf 2015 bis 2018 ein
df_MLP <- df_MLP %>%
filter(Umsatz_NA == FALSE) %>%
filter(Jahr >= 2015 & Jahr <= 2018)
# behalte nur die Spalten, die wir für unser MLP verwenden wollen
df_MLP <- df_MLP %>%
dplyr::select(Datum, Jahr, Warengruppe, Umsatz, KielerWoche, Temperatur, Wochentag_c, SommerferienSH, Feiertag, Silvester_ext, Monat_c)
# Problem: Wir haben fehlende Temperatur-Werte. Filtere diese zunächst raus.
# sum(is.na(df_MLP$Temperatur))
df_MLP <- df_MLP %>% filter(!is.na(Temperatur))Im ersten Schritt verzichten wir auf die Variablen Windgeschwindigkeit und Bewölkung: Wir hatten nämlich in unserer Korrelationsanalyse gesehen, dass die Windgeschwindigkeit allenfalls einen sehr geringen Einfluss hat. Und die Bewölkung würde weitere 8 Dummyvariablen erfordern als Eingabe für unser MLP, daher verzichten wir darauf, um unser Modell nicht zu sehr aufzublähen.
Die Variablen Wochentag_c und Monat_c müssen nun noch dummyfiziert werden: Wir bilden für jeden Wochentag eine Variable mit Ausprägung 0/1. Und entfernen danach die alten Variablen Wochentag_c und Monat_c.
df_MLP <- df_MLP %>%
mutate(Montag=as.integer(df_MLP$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_MLP$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_MLP$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_MLP$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_MLP$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_MLP$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_MLP$Wochentag_c=="Sonntag")) %>%
dplyr::select(-Wochentag_c)
df_MLP <- df_MLP %>%
mutate(Januar=as.integer(df_MLP$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_MLP$Monat_c=="Februar")) %>%
mutate(März=as.integer(df_MLP$Monat_c=="März")) %>%
mutate(April=as.integer(df_MLP$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_MLP$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_MLP$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_MLP$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_MLP$Monat_c=="August")) %>%
mutate(September=as.integer(df_MLP$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_MLP$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_MLP$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_MLP$Monat_c=="Dezember")) %>%
dplyr::select(-Monat_c)Als nächstes wollen wir noch die Temperatur-Variable dummyfizieren, indem wir sie in eine Binärvariable für 4 Intervallbereiche umwandeln. Hintergrund ist, dass die übrigen Input-Variablen bereits Binärvariablen sind und wir damit ein einheitliches Vorgehen für die Befütterung unseres kNN erreichen. Wir wählen die Intervalle und Bezeichnungen wie folgt:
- Temp_eis: < 0 Grad
- Temp_kalt: [0 bis 10 Grad)
- Temp_warm: [10 bis 20 Grad)
- Temp_heiss: >= 20 Grad
df_MLP <- df_MLP %>%
mutate(Temp_eis = as.integer(Temperatur<0)) %>%
mutate(Temp_kalt = as.integer(Temperatur>=0 & Temperatur<10)) %>%
mutate(Temp_warm = as.integer(Temperatur>=10 & Temperatur<20)) %>%
mutate(Temp_heiss = as.integer(Temperatur>=20)) %>%
dplyr::select(-Temperatur)Wir wandeln noch das Datum in eine Integerzahl um, weil wir sonst Probleme beim Import nach Python bekommen.
Für die Trainingsdaten verwenden wir den Zeitraum 2015 bis 2017 und für die Testdaten das Jahr 2018. Die Modellierung erfolgt je Warengruppe, daher teilen wir den Datensatz df_MLP auf.
df_MLP_train <- df_MLP %>% filter(Jahr < 2018)
df_MLP_test <- df_MLP %>% filter(Jahr == 2018)
df_MLP_train_WG1 <- df_MLP_train %>% filter(Warengruppe==1)
df_MLP_train_WG2 <- df_MLP_train %>% filter(Warengruppe==2)
df_MLP_train_WG3 <- df_MLP_train %>% filter(Warengruppe==3)
df_MLP_train_WG4 <- df_MLP_train %>% filter(Warengruppe==4)
df_MLP_train_WG5 <- df_MLP_train %>% filter(Warengruppe==5)
df_MLP_test_WG1 <- df_MLP_test %>% filter(Warengruppe==1)
df_MLP_test_WG2 <- df_MLP_test %>% filter(Warengruppe==2)
df_MLP_test_WG3 <- df_MLP_test %>% filter(Warengruppe==3)
df_MLP_test_WG4 <- df_MLP_test %>% filter(Warengruppe==4)
df_MLP_test_WG5 <- df_MLP_test %>% filter(Warengruppe==5)Das MLP wird in Python aufgebaut, daher exportieren wir die Trainings- und Testdatensätze für die verschiedenen Warengruppen als .csv. Wir verzichten beim Export auf die Zeilenüberschriften.
write_csv(df_MLP_train_WG1, path="data/df_MLP_train_WG1.csv", col_names=FALSE)
write_csv(df_MLP_train_WG2, path="data/df_MLP_train_WG2.csv", col_names=FALSE)
write_csv(df_MLP_train_WG3, path="data/df_MLP_train_WG3.csv", col_names=FALSE)
write_csv(df_MLP_train_WG4, path="data/df_MLP_train_WG4.csv", col_names=FALSE)
write_csv(df_MLP_train_WG5, path="data/df_MLP_train_WG5.csv", col_names=FALSE)
write_csv(df_MLP_test_WG1, path="data/df_MLP_test_WG1.csv", col_names=FALSE)
write_csv(df_MLP_test_WG2, path="data/df_MLP_test_WG2.csv", col_names=FALSE)
write_csv(df_MLP_test_WG3, path="data/df_MLP_test_WG3.csv", col_names=FALSE)
write_csv(df_MLP_test_WG4, path="data/df_MLP_test_WG4.csv", col_names=FALSE)
write_csv(df_MLP_test_WG5, path="data/df_MLP_test_WG5.csv", col_names=FALSE)8.3 Modellparameter
Modell 1 (MLP_mod1)
Im ersten Versuch bauen wir ein vergleichsweise kleines Modell und behalten nur die Variablen für SommerferienSH, Feiertag und Wochentage (Mo - So) als binäre Inputvariablen. Anders als bei der linearen Regression verwenden wir alle Wochentage. Wir haben also insgesamt 9 binäre Inputvariablen. Als output wollen wir den Umsatzschätzer erhalten und brauchen dafür im output layer nur eine Unit mit linearer Aktivierungsfunktion. Der Umsatz soll jedoch positiv sein, also verwenden wir eine “rectified linear unit” (relu).
Dazwischen liegt noch ein hidden layer mit 20 Units, hier verwenden wir die sigmoide Aktivierungsfunktion (sigmoid). Die Verwendung von mehr Einheiten im hidden layer brachte keine besseren Ergebnisse.
Als loss-Funktion verwenden wir standardmäßig den mean squared error (mse). Daneben verwenden wir stochastic gradient descent (SGD) als iterativen Lernalgorithmus mit einer Lernrate von 0.01. Auch hier brachte eine höhere oder niedrigere Lernrate keine besseren Ergebnisse.
Die Gewichte und Schwellwerte werden mit kleinen zufälligen Werten initialisiert unter Anwendung der Standard-Normalverteilung. Wir trainieren das einfache Modell über 50 Epochen, weil wir festgestellt haben, dass nach etwa 40 Epochen die loss-Parameter stabil bleiben. Und die batch-Größe setzen wir auf 10.
Modell 2 (MLP_mod2)
Im zweiten Schritt erweitern wir unser Modell und verwenden noch KielerWoche, Temperatur, Silvester_ext und Monat als Inputvariablen. Monat_c wurde dafür dummyfiziert. Und die Temperatur ist in 4 Bereiche und damit 4 Binärvariablen umgewandelt worden, damit wir einheitlich nur Binär-Inputs verwenden.
Insgesamt haben wir 27 Inputvariablen und erhöhen die Anzahl der Neuronen im hidden layer von 20 auf 50. Eine weitere Erhöhung liefert keine signifikant besseren Ergebnisse.
Im Training verwenden wir diesmal 100 Epochen, weil das komplexere Modell erst nach ca. 80 Epochen stabile loss-Werte zeigt.
8.4 Ergebnisse
Modell 1 (MLP_mod1)
Wir haben je ein Modell pro Warengruppe trainiert. Python liefert uns folgende finalen Parameter als train error:
| Modell | MSE | MAE |
|---|---|---|
| mod1_WG1 | 916 | 21.8 |
| mod1_WG2 | 6489 | 64.0 |
| mod1_WG3 | 2012 | 35.5 |
| mod1_WG4 | 845 | 20.2 |
| mod1_WG5 | 6891 | 44.8 |
Wenn wir in Python die trainierten Modelle auf die Testdaten anwenden, erhalten wir Umsatzschätzer je Warengruppe, die wir als csv hier einladen.
df_MLP_test_mod1_WG1_pred <- read_csv("data/df_MLP_test_mod1_WG1_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG2_pred <- read_csv("data/df_MLP_test_mod1_WG2_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG3_pred <- read_csv("data/df_MLP_test_mod1_WG3_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG4_pred <- read_csv("data/df_MLP_test_mod1_WG4_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG5_pred <- read_csv("data/df_MLP_test_mod1_WG5_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod1_WG1_pred) <- "Umsatz_mod1_WG1"
colnames(df_MLP_test_mod1_WG2_pred) <- "Umsatz_mod1_WG2"
colnames(df_MLP_test_mod1_WG3_pred) <- "Umsatz_mod1_WG3"
colnames(df_MLP_test_mod1_WG4_pred) <- "Umsatz_mod1_WG4"
colnames(df_MLP_test_mod1_WG5_pred) <- "Umsatz_mod1_WG5"Füge die Ergebnisse an die Test-Daten (für jede Warengruppe) und erstelle dann eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_MLP_vgl_kennz:
# mod1_WG1
df_MLP_test_mod1_WG1 <- cbind(df_MLP_test_WG1, df_MLP_test_mod1_WG1_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG1 <- df_MLP_test_mod1_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG1 <- df_MLP_test_mod1_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- temp
# mod1_WG2
df_MLP_test_mod1_WG2 <- cbind(df_MLP_test_WG2, df_MLP_test_mod1_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG2 <- df_MLP_test_mod1_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG2 <- df_MLP_test_mod1_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG3
df_MLP_test_mod1_WG3 <- cbind(df_MLP_test_WG3, df_MLP_test_mod1_WG3_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG3 <- df_MLP_test_mod1_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG3 <- df_MLP_test_mod1_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG4
df_MLP_test_mod1_WG4 <- cbind(df_MLP_test_WG4, df_MLP_test_mod1_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG4 <- df_MLP_test_mod1_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG4 <- df_MLP_test_mod1_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG5
df_MLP_test_mod1_WG5 <- cbind(df_MLP_test_WG5, df_MLP_test_mod1_WG5_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG5 <- df_MLP_test_mod1_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG5 <- df_MLP_test_mod1_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
prog_MLP_vgl_kennz## # A tibble: 5 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 26 -4 20 20 1422 38
## 2 346 130413 377 70 4 20 19 6733 82
## 3 346 59316 171 41 3 26 24 2694 52
## 4 345 28354 82 19 17 26 23 604 25
## 5 346 93912 271 63 19 25 23 9873 99
## # ... with 1 more variable: Modell <chr>
Das einfache Modell (mod1), das für die Umsatzschätzung nur SommerferienSH, Feiertag und Wochentage (Mo - So) als Inputvariablen einbezieht, liefert unterschiedliche Ergebnisse für die verschiedenen Warengruppen: Zunächst fällt auf, dass die mittlere relative Abweichung (MPE) für die Warengruppen 1, 2 und 3 nahe Null ist, während wir für die beiden Warengruppen 4 und 5 offenbar den Umsatz systematisch zu hoch schätzen.
Der gewichtete mittlere Absolutwert der relativen Abweichung (WAPE) zeigt für die Warengruppe 2 den niedrigsten Fehler. Wir hatten jedoch bspw. für das beste naive Schätzmodell (glDS_4T_erw) einen deutlich niedrigeren Fehler gesehen für Warengruppe 2 (WAPE = 11).
Trotzdem wollen wir uns die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_MLP_vgl_relAbw. Diese müssen wir dann noch pivotieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- df_MLP_test_mod1_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_MLP_vgl_relAbw)[2]="mod1_WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[3]="mod1_WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[4]="mod1_WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[5]="mod1_WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[6]="mod1_WG5"
# pivotieren
prog_MLP_vgl_relAbw <- prog_MLP_vgl_relAbw %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_MLP_vgl_relAbw %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich MLP Modell 1: Relative Abweichung") +
xlab("Modell_Warengruppe") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
Modell 2 (MLP_mod2)
Im zweiten Schritt erweitern wir unser Modell und verwenden noch KielerWoche, Temperatur, Silvester_ext und Monat als Inputvariablen. Monat_c wurde dafür dummyfiziert. Und die Temperatur ist in 4 Bereiche und damit 4 Binärvariablen umgewandelt worden, damit wir einheitlich nur Binär-Inputs verwenden.
Wir haben je ein Modell pro Warengruppe trainiert. Python liefert uns folgende finalen Parameter als train error:
| Modell | MSE | MAE |
|---|---|---|
| mod1_WG1 | 683 | 18.9 |
| mod1_WG2 | 2731 | 38.7 |
| mod1_WG3 | 851 | 21.6 |
| mod1_WG4 | 528 | 16.7 |
| mod1_WG5 | 1588 | 30.2 |
Wenn wir in Python die trainierten Modelle auf die Testdaten anwenden, erhalten wir Umsatzschätzer je Warengruppe, die wir als csv hier einladen.
df_MLP_test_mod2_WG1_pred <- read_csv("data/df_MLP_test_mod2_WG1_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG2_pred <- read_csv("data/df_MLP_test_mod2_WG2_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG3_pred <- read_csv("data/df_MLP_test_mod2_WG3_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG4_pred <- read_csv("data/df_MLP_test_mod2_WG4_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG5_pred <- read_csv("data/df_MLP_test_mod2_WG5_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod2_WG1_pred) <- "Umsatz_mod2_WG1"
colnames(df_MLP_test_mod2_WG2_pred) <- "Umsatz_mod2_WG2"
colnames(df_MLP_test_mod2_WG3_pred) <- "Umsatz_mod2_WG3"
colnames(df_MLP_test_mod2_WG4_pred) <- "Umsatz_mod2_WG4"
colnames(df_MLP_test_mod2_WG5_pred) <- "Umsatz_mod2_WG5"Füge die Ergebnisse an die Test-Daten (für jede Warengruppe) und erstelle dann eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_MLP_vgl_kennz_mod2:
# mod2_WG1
df_MLP_test_mod2_WG1 <- cbind(df_MLP_test_WG1, df_MLP_test_mod2_WG1_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG1 <- df_MLP_test_mod2_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG1 <- df_MLP_test_mod2_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- temp
# mod2_WG2
df_MLP_test_mod2_WG2 <- cbind(df_MLP_test_WG2, df_MLP_test_mod2_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG2 <- df_MLP_test_mod2_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG2 <- df_MLP_test_mod2_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG3
df_MLP_test_mod2_WG3 <- cbind(df_MLP_test_WG3, df_MLP_test_mod2_WG3_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG3 <- df_MLP_test_mod2_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG3 <- df_MLP_test_mod2_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG4
df_MLP_test_mod2_WG4 <- cbind(df_MLP_test_WG4, df_MLP_test_mod2_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG4 <- df_MLP_test_mod2_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG4 <- df_MLP_test_mod2_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG5
df_MLP_test_mod2_WG5 <- cbind(df_MLP_test_WG5, df_MLP_test_mod2_WG5_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG5 <- df_MLP_test_mod2_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG5 <- df_MLP_test_mod2_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
prog_MLP_vgl_kennz_mod2## # A tibble: 5 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 27 -4 21 20 1453 38
## 2 346 130413 377 46 7 13 12 3519 59
## 3 346 59316 171 34 -9 19 20 2051 45
## 4 345 28354 82 18 5 22 22 572 24
## 5 346 93912 271 43 -1 16 16 3367 58
## # ... with 1 more variable: Modell <chr>
Das erweiterte Modell (mod2) liefert im Gegensatz zum einfachen Modell (mod1) einheitlichere Ergebnisse für die verschiedenen Warengruppen: Zunächst fällt auf, dass die mittlere relative Abweichung (MPE) nun für die beiden Warengruppen 4 und 5 nahe Null liegt und sich unser Schätzer für die Warengruppen 2 und 3 von Null entfernt haben.
Der gewichtete mittlere Absolutwert der relativen Abweichung (WAPE) zeigt wieder für die Warengruppe 2 den niedrigsten Fehler und liegt jetzt auf einem vergleichbaren Niveau zum besten naiven Schätzmodell (glDS_4T_erw), für Warengruppe 2 hatten wir dort einen WAPE = 11 gesehen.
Als nächstes wollen wir uns die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_MLP_vgl_relAbw_mod2. Diese müssen wir dann noch pivotieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- df_MLP_test_mod2_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_MLP_vgl_relAbw_mod2)[2]="mod2_WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[3]="mod2_WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[4]="mod2_WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[5]="mod2_WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[6]="mod2_WG5"
# pivotieren
prog_MLP_vgl_relAbw_mod2 <- prog_MLP_vgl_relAbw_mod2 %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_MLP_vgl_relAbw_mod2 %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich MLP Modell 2: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
Die Umsatzschätzung gelingt offenbar für die Warengruppe 2 (= Brötchen) ab besten.
8.5 Vergleich der MLP Modelle
!!! Hier fehlt noch eine ausführliche Vergleichsbetrachtung.
Fazit DL Modelle
Wir haben in diesem Abschnitt zwei Multilayer Perceptron Modelle eingesetzt und genauer untersucht. Die Ergebnisse sind brauchbar aber nicht umwerfend. In beiden Modellen haben wir stochastic gradiend descent einen iterativen Lernalgorithmus verwendet, der keine Garantie gibt, das globale Optimum für die Gewichte und Schwellwerte zu finden. Das kann ein Grund für die mangelnde Ergebnis-Qualität sein.
Die Parameter - wie bspw. die Lernrate, die Anzahl der hidden layers und der Anzahl der Neuronen im hidden layer - haben wir empirisch festgelegt. Hierfür gibt es keine “optimalen Werte”.
Insgesamt stellen wir fest, dass die so gebauten MLP Modelle dem Problem nicht gerecht werden. Vermutlich würde man mit rekursiven Netzen und/oder dem Einsatz von long-short-term-memory (LSTM) Einheiten deutlich bessere Ergebnisse erzielen. Das sprengt jedoch den Umfang dieser Projektarbeit und wird daher nicht weiter betrachtet.
Wir hatten gesehen, dass das komplexe Modell (mod2) für die Warengruppe 2 in Bezug auf den WAPE gute Ergebnisse liefert. Ein Ansatz ist, das Modell gezielt für diese Warengruppe noch zu erweitern. Hier haben wir versucht, einen zweiten hidden layer mit 20 Einheiten in das Modell zu integrieren. Allerdings verschlechterten sich dadurch die Prognose-Ergebnisse, so dass wir den Ansatz nicht weiter verfolgt haben. Alternativ haben wir ein Kompromiss-Modell (mod3) getestet, das nur die Variablen SommerferienSH, Feiertag, Silvester_ext, Samstag, Sonntag, Juli und August enthält. Und dieses Modell haben wir versucht, für Warengruppe 2 zu optimieren durch Variation der Units im hidden layer, Anwendung anderer Lernalgorithmen (Adam) oder Hinzunahme eines weiteren hidden layers - ohne Erfolg.
Auch könnte man das Modell gezielt auf die Feiertags-Effekte trainieren, um dafür bessere Ergebnisse zu erzielen. Diese Idee stellt eine Ausbaustufe dar, die wir hier nicht umgesetzt haben.
Insgesamt ging es hier eher darum, Erfahrungswerte in der praktischen Anwendung von DL-Verfahren zu sammeln und das ist in der Tat sehr gut gelungen.
8.6 Zugabe
Weil wir uns vom MLP bessere Ergebnisse erhofft hatten, haben wir noch einen drauf gesetzt und noch ein viertes MLP (mod4) getestet. Dafür haben wir den vollständigen SVM-Datensatz verwendet mit allen Inputvariablen und skalierten Wettervariablen sowie skaliertem Umsatz.
Getestet haben wir wieder sequentielle MLP-Modelle, diesmal aber gezielt mit mehreren hidden layers. Die besten Ergebnisse lieferte ein MOdell mit zwei hidden layers, bestehend aus 100 bzw. 50 Einheiten, jeweils mit ‘relu’ Aktivierungsfunktionen. Als Lernalgorithmus haben wir dabei ‘Adam’ angewendet mit einer Lernrate von 0.001, gleichzeitig haben wir online learning (batch_size = 1) angewendet und das Modell über 20 Epochen trainiert.
Diese Parametereinstellungen lieferten die besten Ergebnisse (df_MLP_test_mod4_WG2_pred.csv). Verlängert man die Trainingsphase um weitere 20 Epochen (df_MLP_test_mod4_WG2_pred2.csv), verschlechtert sich die Prognosegüte bei Anwendung des Modells auf die Testdaten. Ein dritter hidden layer mit 25 Einheiten (df_MLP_test_mod4_WG2_pred3.csv) bringt keinen Mehrwert. Und auch wenn man die Anzahl der Einheiten im ersten hidden layer verdoppelt (df_MLP_test_mod4_WG2_pred4.csv), erzielt man keine genaueren Schätzwerte.
Hier die Testergebnisse - exemplarisch für Warengruppe 2:
df_MLP_test_mod4_WG2_pred <- read_csv("data/df_MLP_test_mod4_WG2_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod4_WG2_pred) <- "Umsatz_mod4_WG2"Füge die Ergebnisse an die Test-Daten und bilde die Gütekennzahlen. Vorher müssen wir den Umsatz wieder zurück skalieren:
# mod1_WG1
df_MLP_test_mod4_WG2 <- cbind(df_SVM_test_WG2, df_MLP_test_mod4_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod4_WG2 <- df_MLP_test_mod4_WG2 %>%
mutate(Umsatz = Umsatz * 2000) %>%
mutate(Umsatz_mod4_WG2 = Umsatz_mod4_WG2 * 2000) %>%
mutate(Prognose_zuhoch = (Umsatz_mod4_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod4_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod4_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod4_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod4_WG2 <- df_MLP_test_mod4_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
df_MLP_test_mod4_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))## # A tibble: 1 x 9
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 260825860 753832 753456 -100 100 100 6.35e11 796674
Der WAPE liegt bei 10 und damit knapp unterhalb des besten naiven Modells. Das hat uns ermutigt, Modell 4 auf eine andere Warengruppe anzuwenden.
Hier die Ergebnisse für Warengruppe 4:
df_MLP_test_mod4_WG4_pred <- read_csv("data/df_MLP_test_mod4_WG4_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod4_WG4_pred) <- "Umsatz_mod4_WG4"Füge die Ergebnisse an die Test-Daten und bilde die Gütekennzahlen. VORHER den Umsatz wieder zurück skalieren:
# mod1_WG1
df_MLP_test_mod4_WG4 <- cbind(df_SVM_test_WG4, df_MLP_test_mod4_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod4_WG4 <- df_MLP_test_mod4_WG4 %>%
mutate(Umsatz = Umsatz * 2000) %>%
mutate(Umsatz_mod4_WG4 = Umsatz_mod4_WG4 * 2000) %>%
mutate(Prognose_zuhoch = (Umsatz_mod4_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod4_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod4_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod4_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod4_WG4 <- df_MLP_test_mod4_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
df_MLP_test_mod4_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))))## # A tibble: 1 x 9
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 345 56707980 164371 164281 -100 100 100 2.91e10 170597
Unsere Hoffnung hat sich jedoch nicht erfüllt: Der WAPE ist schlechter als für das einfachere Modell 2 (mod2) für die Warengruppe 4.
9. Modellvergleich über alle verwendeten Verfahren
## # A tibble: 13 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 27 -4 21 20 1453 38
## 2 346 130413 377 46 7 13 12 3519 59
## 3 346 59316 171 34 -9 19 20 2051 45
## 4 345 28354 82 18 5 22 22 572 24
## 5 346 93912 271 43 -1 16 16 3367 58
## 6 346 45738 132 23 -4 18 18 965 31
## 7 346 45738 132 23 -4 18 18 949 31
## 8 346 130413 377 45 9 13 12 3161 56
## 9 346 130413 377 45 9 13 12 3189 56
## 10 346 130413 377 45 9 13 12 3197 57
## 11 346 93912 271 38 4 15 14 2538 50
## 12 346 93912 271 39 4 15 14 2570 51
## 13 346 93912 271 38 4 14 14 2541 50
## # ... with 1 more variable: Modell <chr>